;;;----------------------------- (setf string "\\n") ; two characters, \ and an n (setf string "John 'Maddog' Orwant") ; literal single quotes ;;;----------------------------- ;; newlines may be inserted literally (setf string " ") ; a "newline" character ;; or by creating a string explicitly (setf string (make-string 1 :initial-element #\Newline)) ;; or by using format with a nil output stream (setf string (format nil "~%")) (setf string "John \"Maddog\" Orwant") ; literal double quotes ;;;----------------------------- (setf string "John 'Maddog' Orwant") ; literal single quotes ;;;----------------------------- (setf string " This is a multiline string, terminated by a double quotation mark. ") ;;;----------------------------- ;; There are no CL equivalents to Perl's other ways of quoting ;; strings (q//, etc). ;;;----------------------------- |
;;;----------------------------- ;; assign a substring to a variable (setf value (subseq string offset (+ offset count))) (setf value (subseq string offset)) ;; edit a substring (setf string (concatenate 'string (subseq string 0 offset) newstring (subseq string (+ offset count)))) (setf string (concatenate 'string (subseq string 0 offset) newtail)) ;;;----------------------------- ;; get a 5-byte string, skip 3, then grab 2 8-byte strings, then the ;; rest (setf leading (subseq data 5) s1 (subseq data 8 8) s2 (subseq data 16 8) trailing (subseq data 24)) ;; split at five byte boundries (let ((length (length string))) (loop for idx from 0 upto length by 5 collect (subseq string idx (min length (+ idx 5))))) ;; chop string into individual characters (loop for idx from 0 upto (1- (length string)) collect (char string idx)) ;;;----------------------------- (defparameter *string* "This is what you have") ;;; +012345678901234567890 Indexing forwards (left to right) ;;; 109876543210987654321- Indexing backwards (right to left) (let ((first (subseq *string* 0 1)) ; "T" (start (subseq *string* 5 7)) ; "is" (rest (subseq *string* 13)) ; "you have" (last (subseq *string* (+ (length *string*) -1))) ; "e" (end (subseq *string* (+ (length *string*) -4))) ; "have" (piece (subseq *string* (+ (length *string*) -8) (+ (length *string*) -8 3)))) ; "you" (list first start rest last end piece)) ;; ("T" "is" "you have" "e" "have" "you") ;;;----------------------------- (defparameter *string* "This is what you have") (print *string*) ;; This is what you have ;; Change "is" to "wasn't" (setf *string* (concatenate 'string (subseq *string* 0 5) "wasn't" (subseq *string* (+ 5 2)))) ;; This wasn't what you have ;; Replace last 12 characters (setf *string* (concatenate 'string (subseq *string* 0 (+ (length *string*) -12)) "ondrous")) ;; This wasn't wondrous ;; Delete first character (setf *string* (subseq *string* 1)) ;; his wasn't wondrous ;; Delete last 10 characters (setf *string* (subseq *string* 0 (+ (length *string*) -10))) ;; his wasn' ;;;----------------------------- ;; you can test substrings with the :start and :end keyword parameters ;; of CL-PPCRE:SCAN (when (scan "pattern" *string* :start (- (length *string*) 10)) (format t "Pattern matches in last 10 characters~%")) ;; substitute "at" for "is", restricted to first five characters (concatenate 'string (regex-replace "is" *string* "at" :start 0 :end (min (length *string*) 5)) (when (> (length *string*) 5) (subseq *string* 5))) ;;;----------------------------- ;; exchange the first and last letters in a string (let ((a "make a hat")) ;; ROTATEF is CL's general-purpose swap macro (rotatef (char a 0) (char a (1- (length a)))) (princ a)) ;; take a ham ;;;----------------------------- ;; extract column with SUBSEQ (let* ((a "To be or not to be") (b (subseq a 6 12))) ; skip 6, grab 6 (format t "~A~%" b) ;; or not ;; forward 6, grab 2; backward 5, grab 2 (destructuring-bind (b c) `(,(subseq a 6 8) ,(subseq a 3 5)) (format t "~A~%~A~%" b c))) ;; or ;; be ;;;----------------------------- (defun cut2fmt (&rest positions) "Useless in CL, which lacks Perl's unpack(); here for completeness." (let ((template "") (lastpos 1)) (dolist (place positions) (setf template (format nil "~AA~D " template (- place lastpos))) (setf lastpos place)) (setf template (concatenate 'string template "A*")) template)) (let ((fmt (cut2fmt 8 14 20 26 30))) (format t "~A~%" fmt)) ;; A7 A6 A6 A6 A4 A* ;;;----------------------------- |
;;;----------------------------- ;; use b if b is true, else c (setf a (or b c)) ;; set x to y unless x is already true (unless x (setf x y)) ;;;----------------------------- ;; use B if B is defined, otherwise C (setf a (if (boundp 'b) b c)) ;;;----------------------------- (setf foo (or bar "DEFAULT VALUE")) ;;;----------------------------- #+sbcl (defparameter ARGV (copy-seq (cdr *posix-argv*)) "Arguments from shell, Perl style") (setf dir (or (pop ARGV) "/tmp")) ;;;----------------------------- (setf dir (or (nth 0 ARGV) "/tmp")) ;;;----------------------------- (setf dir (if (plusp (length ARGV)) (pop ARGV) "/tmp")) ;;;----------------------------- (setf dir (if (plusp (length ARGV)) (nth 0 ARGV) "/tmp")) ;;;----------------------------- (setf count (make-hash-table)) (incf (gethash (or shell "/bin/sh") count 0)) ;;;----------------------------- ;; find the user name on Unix systems (setf user (or (posix-getenv "USER") (posix-getenv "LOGNAME") #+sbcl (let ((uid (sb-posix:getuid))) (or (sb-posix:passwd-name (sb-posix:getpwuid uid)) (format nil "Unknown uid number ~a" uid))) #-sbcl "Unknown uid")) ;;;----------------------------- (setf starting-point (or starting-point "Greenwich")) ;;;----------------------------- ;; Perl array-to-array assignment copies the array, hence the need for ;; COPY-SEQ below. (unless (plusp (length a)) (setf a (copy-seq b))) ; copy only if empty (setf a (copy-seq (if (plusp (length b)) b c))) ; assign b if nonempty, else c ;;;----------------------------- |
;;;----------------------------- ;; There are several ways to swap variables in CL. ROTATEF is usually ;; the simplest choice. (rotatef VAR1 VAR2) (psetq VAR1 VAR2 VAR2 VAR1) (multiple-value-setq (VAR1 VAR2) (values VAR2 VAR1)) ;;;----------------------------- (setf temp a a b b temp) ;;;----------------------------- (let ((a "alpha") (b "omega")) (rotatef a b)) ; the first shall be last -- and versa vice ;;;----------------------------- (destructuring-bind (alpha beta production) ;; In CL one would normally use symbols here: ;; '(January March August) '("January" "March" "August") ;; move beta to alpha, ;; move production to beta, ;; move alpha to production (rotatef alpha beta production)) ;;;----------------------------- |
;;----------------------------- (setq num (char-code char)) (setq char (code-char num)) ;;----------------------------- (setq char (format nil "~c" (code-char num))) (format t "Number ~d is character ~c~%" num (code-char num)) ;; Number 101 is character e ;;;----------------------------- (setq ASCII (map 'list #'char-code string)) (setq string (map 'string #'code-char ASCII)) ;;----------------------------- (setq ascii-value (char-code #\e)) ; now 101 (setq character (code-char 101)) ; now #\e ;;----------------------------- (format t "Number ~D is character ~C~%" 101 (code-char 101)) ;;----------------------------- (let ((ascii-character-numbers (map 'list #'char-code "sample"))) (format t "~{~A~^ ~}~%" ascii-character-numbers) ;; 115 97 109 112 108 101 (setf word (map 'string #'code-char ascii-character-numbers)) (setf word (map 'string #'code-char #(115 97 109 112 108 101))) ; same (format t "~A~%" word)) ;; sample ;;;----------------------------- (let* ((hal "HAL") (ibm (map 'string (lambda (char) (code-char (1+ (char-code char)))) ; add one to each ASCII value hal))) (format t "~A~%" ibm)) ; prints "IBM" ;;;----------------------------- |
;;;----------------------------- (setq array (map 'list #'string string)) (setq array (loop for char across string collect (char-code char))) ;;;----------------------------- (do-matches-as-strings (match "(.)" string) ;; do something with MATCH ) ;;;----------------------------- (let ((seen (make-hash-table)) (string "an apple a day")) (loop for char across string do (incf (gethash char seen 0))) (let ((chars (loop for char being each hash-key of seen collect char))) (format t "unique chars are: ~{~C~}~%" (sort chars '< :key 'char-code)))) ;; unique chars are: adelnpy ;;;----------------------------- (let ((string "an apple a day")) (format t "sum is ~D~%" (reduce #'+ string :key #'char-code))) (let ((string "an apple a day")) (format t "sum is ~D~%" (loop for char across string summing (char-code char)))) ;;;----------------------------- (let ((string "an apple a day")) (format t "sum is ~D~%" (loop for char across string sum (char-code char)))) ;; prints "1248" if string was "an apple a day" ;;;----------------------------- ;; There's no equivalent to Perl's unpack(), this is about as close as ;; you can get. (setf sum (loop for char across string sum (char-code char))) ;;;----------------------------- ;; In CL it makes more sense to call this function from the REPL than ;; it does to put it into a separate script. E.g., ;; > (sum "/tmp/xyz" "~/foo/bar.txt") (defun sum (&rest files) (let ((sum 0)) (dolist (filename files) (with-open-file (file filename :element-type 'unsigned-byte) (do ((b (read-byte file nil :eof) (read-byte file nil :eof))) ((eql b :eof)) (incf sum b)))) (let ((r (+ (mod sum (expt 2 16)) (truncate (/ (mod sum (expt 2 32)) (expt 2 16)))))) (+ (mod r (expt 2 16)) (truncate (/ r (expt 2 16))))))) ;;;----------------------------- ;;CL-USER> (sum "/mach.sym") ;;24298 ;;;----------------------------- ;;%cksum -o 2 /mach.sym ;;24298 1203 /mach.sym ;;;----------------------------- (defun slowcat (number-or-filename &rest more-files) "The first argument can be a number of seconds to sleep between characters, otherwise it should be a file name." (let ((delay (if (numberp number-or-filename) number-or-filename 1)) (files (if (numberp number-or-filename) more-files (cons number-or-filename more-files)))) (dolist (filename files) (with-open-file (file filename) (do ((c (read-char file nil :eof) (read-char file nil :eof))) ((eql c :eof)) (format t "~C" c) (finish-output) (sleep (* delay 0.005))))))) |
;;;----------------------------- (setq revbytes (reverse string)) ;;;----------------------------- (setq revwords (format nil "~{~A~^ ~}" (reverse (split " " string)))) (setq revwords (reverse (do* ((stringstream (make-string-input-stream string)) (result nil (cons next result)) (next (read stringstream nil 'eos) (read stringstream nil 'eos))) ((equal next 'eos) (reverse result))))) ;;;----------------------------- (setq gnirts (reverse string)) ; reverse letters in string (setq sdrow (reverse words)) ; reverse elements in words (setq confused (reverse (apply #'concatenate 'string words))) ; reverse letters in join("", @words) ;;;----------------------------- (setq string "Yoda said, \"can you see this?\"") (setq allwords (split " " string)) (setq revwords (format nil "~{~A~^ ~}" (reverse allwords))) (format t "~A~%" revwords) ;this?" see you "can said, Yoda ;;;----------------------------- (setq revwords (format nil "~{~A~^ ~}" (reverse (split " " string)))) ;;;----------------------------- (setq revwords (apply #'concatenate 'string (split "(\\s+)" string :with-registers-p t))) ;;;----------------------------- (defun palindrome-p (word) (string= word (reverse word))) (palindrome-p "reviver") ;; T ;;;----------------------------- (with-open-file (inf "/usr/share/dict/words") (loop for word = (read-line inf nil nil) while word when (and (string= word (reverse word)) (> (length word) 5)) do (format t "~a~%" word))) ;; deedeed ;; degged ;; hallah ;; kakkak ;; murdrum ;; redder ;; repaper ;; retter ;; reviver ;; rotator ;; sooloos ;; tebbet ;; terret ;;;----------------------------- |
;;;----------------------------- ;;;----------------------------- (defun tab-expand (string &optional (tabstop 8)) (flet ((needed-spaces (target-string start end match-start match-end reg-starts reg-ends) (declare (ignore target-string start end reg-starts reg-ends)) (make-string (- (* (- match-end match-start) tabstop) (mod match-start tabstop)) :initial-element #\Space))) (regex-replace-all "\\t+" string #'needed-spaces))) (defun tab-unexpand (string &optional (tabstop 8)) (flet ((needed-tabs (target-string start end match-start match-end reg-starts reg-ends) (declare (ignore target-string start end reg-starts reg-ends)) (let ((match-length (- match-end match-start))) (concatenate 'string (make-string (floor match-length tabstop) :initial-element #\Tab) (make-string (mod match-length tabstop) :initial-element #\Space))))) (regex-replace-all " +" string #'needed-tabs))) ;;;----------------------------- (loop for line = (read-line *standard-input* nil nil) while line do (format t "~A~%" (tab-expand line))) ;;;----------------------------- (loop for line = (read-line *standard-input* nil nil) while line do (format t "~A~%" (tab-unexpand line))) ;;;----------------------------- |
;;;----------------------------- (setf text "You owe $debt to me") ;;;----------------------------- (defun global-deref (match var-name) "Helper function to simulate Perl's string interpolation in regexps." (write-to-string (symbol-value (intern (string-upcase var-name))))) (setf text (regex-replace-all "\\$(\\w+)" text #'global-deref :simple-calls t)) ;;;----------------------------- (setq rows 24 cols 80) (setq text "I am $rows high and $cols long") (setq text (regex-replace-all "\\$(\\w+)" text #'global-deref :simple-calls t)) (format t "~A~%" text) ;; I am 24 high and 80 long ;;;----------------------------- (setf text "I am 17 years old") (setf text (regex-replace-all "(\\d+)" text (lambda (match num-str) (declare (ignore match)) (write-to-string (* 2 (parse-integer num-str)))) :simple-calls t)) ;;;----------------------------- (* 2 17) ;;;----------------------------- ;; expand variables in text, but put an error message in ;; if the variable isn't defined (flet ((deref-with-err (match word) (declare (ignore match)) (let ((word-sym (intern (string-upcase word)))) (if (boundp word-sym) (write-to-string (symbol-value word-sym)) (format nil "[NO VARIABLE: $~a]" word-sym))))) (setf text (regex-replace-all "\\$(\\w+)" text #'deref-with-err :simple-calls t))) ;;;----------------------------- |
;;;----------------------------- (setf big (string-upcase little)) ; "bo peep" -> "BO PEEP" (setf little (string-downcase big)) ; "JOHN" -> "john" ;; Reminder: the following depends on CL-INTERPOL. (setf big #?"\U$(little)") ; "bo peep" -> "BO PEEP" (setf little #?"\L$(big)") ; "JOHN" -> "john" ;;;----------------------------- (setf big (string-upcase little :end 1) ; "bo" -> "Bo" (setf little (string-downcase BIG :end 1)) ; "BoPeep" -> "boPeep" (setf big #?"\u$(little)") ; "bo" -> "Bo" (setf little #?"\l$(big)") ; "BoPeep" -> "boPeep" ;;;----------------------------- (setf beast "dromedary") ;; Capitalize various parts of beast (setf capit (string-upcase beast :end 1)) ; Dromedary (setf capit #?"\u\L$(beast)") ; (same) (setf capall (string-upcase beast)) ; DROMEDARY (setf capall #?"\U$(beast)") ; (same) (setf caprest (string-downcase (string-upcase beast) :end 1)) ; dROMEDARY (setf caprest #?"\l\U$(beast)") ; (same) ;;;----------------------------- ;; capitalize each word's first character, downcase the rest (setf text "thIS is a loNG liNE") (format t "~A~%" (string-capitalize text)) ;; This Is A Long Line ;;;----------------------------- ;; string= is case-sensitive, string-equal is case-insensitive (when (string-equal a b) (format t "a and b are the same~%")) ;;;----------------------------- ;; It's considered bad form to perform bitwise operations on character ;; types, and breaks unicode-aware lisps. Trust the compiler to ;; optimize. (defun randcase (char) (if (< (random 100) 20) (char-upcase char) (char-downcase char))) ;;;----------------------------- |
;;;----------------------------- (setf answer (concatenate 'string var1 (func) var2)) ;;;----------------------------- (setf answer (format nil "STRING ~{~A~} MORE STRING" list-expr)) (setf answer (format nil "STRING ~A MORE STRING" atomic-expr)) ;;;----------------------------- (setf phrase (format nil "I have ~D guanacos." (1+ n))) (setf phrase #?"I have ${(1+ n)} guanacos.") ; uses CL-INTERPOL ;;;----------------------------- (format t "I have ~D guanacos.~%" (1+ n)) ;;;----------------------------- (some-func (format nil "What you want is ~{~A~} items" (split ":" rec))) ;;;----------------------------- (let ((text (format nil "~ To: ~A From: Your Bank Cc: ~{~A~^, ~} Date: ~A (today) Dear ~A, Today, you bounced check number ~D to us. Your account is now closed. Sincerely, the management " naughty (get-manager-list naughty) (let (date-str (with-output-to-string (str) (run-program "/bin/date" nil :output str))) (subseq date-str 0 (1- (length date-str)))) naughty (+ 500 (random 100))))) (unless (send-mail text target) (error "Couldn't send mail"))) ;;;----------------------------- |
;;;----------------------------- ;; all in one (setf var (regex-replace-all (create-scanner #?r"^\s+" :multi-line-mode t) "your text goes here " "")) ;; or with two steps (setf var "your text goes here ") (setf var (regex-replace-all (create-scanner #?r"^\s+" :multi-line-mode t) var "")) ;;----------------------------- (setf var (regex-replace-all (create-scanner #?r"^\s+" :multi-line-mode t) " The five varieties of camelids are the familiar camel, his friends the llama and the alpaca, and the rather less well-known guanaco and vicuña. " "")) ;;;----------------------------- (defun fix (string) (regex-replace-all (create-scanner #?r"^\s+" :multi-line-mode t) string "")) (format t "~A~%" (fix " My stuff goes here ") ;;;----------------------------- (setf quote (regex-replace-all (create-scanner #?r"\s+--") (regex-replace-all (create-scanner #?r"^\s+" :multi-line-mode t) " ...we will have peace, when you and all your works have perished--and the works of your dark master to whom you would deliver us. You are a liar, Saruman, and a corrupter of mens hearts. --Theoden in /usr/src/perl/taint.c " "") " --")) ;;----------------------------- (when *remember-the-main* (setf perl-main-C (dequote " @@@ int @@@ runops() { @@@ SAVEI32(runlevel); @@@ runlevel++; @@@ while ( op = (*op->op_ppaddr)() ) ; @@@ TAINT_NOT; @@@ return 0; @@@ } " ;; add more code here if you want ))) ;;;----------------------------- (defparameter *poem* (dequote " Now far ahead the Road has gone, And I must follow, if I can, Pursuing it with eager feet, Until it joins some larger way Where many paths and errands meet. And whither then? I cannot say. --Bilbo in /usr/src/perl/pp_ctl.c ")) (format t "Here's your poem:~%~%~A~%" *poem*) ;;;----------------------------- (defun dequote (string) ;; Can't get multiple values returned thru the OR, hence the use of ;; DESTRUCTURING-BIND instead of MULTIPLE-VALUE-BIND (destructuring-bind (white leader) ; common whitespace and common leading string (or (register-groups-bind ($1 $2) (#?r/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/ string) (list $2 (quote-meta-chars $1))) (list (scan-to-strings #?r"^(\s+)" string) "")) (regex-replace-all (create-scanner (format nil #?r"^\s*?~a(?:~a)?" leader white) :multi-line-mode t) string ""))) ;;;----------------------------- |
;; backslash (setf var (regex-replace-all "([CHARLIST])" var "\\\1")) ;; double (setf var (regex-replace-all "([CHARLIST])" var "\\1\\1")) ;;;----------------------------- (setf string (regex-replace-all "%" string "%%")) ;;;----------------------------- (setf string "Mom said, \"Don't do that.\"") (setf string (regex-replace-all "(['\"])" string #?r"\\\1")) ;;;----------------------------- (setf string "Mom said, \"Don't do that.\"") (setf string (regex-replace-all "(['\"])" string #?r"\1\1")) ;;;----------------------------- (setf string (regex-replace-all #?r"([^A-Z])" string #?r"\\\1")) ;;;----------------------------- (setf string #?r"this \Qis a test!\E") (setf string "this is\\ a\\ test\\!") (setf string (concatenate 'string "this " (quote-meta-chars "is a test!"))) ;;;----------------------------- |
;;;----------------------------- (setf string (regex-replace #?r/^\s+/ string "")) (setf string (regex-replace #?r/\s+$/ string "")) ;;;----------------------------- ;;; The closest thing to Perl's wantarray is CL's ability to return ;;; multiple values from a function. Unless the caller uses ;;; MULTIPLE-VALUE-BIND (or, in this case, MULTIPLE-VALUE-LIST), they ;;; will only "see" the first value. Note also that, normally, you'd ;;; use CL's built-in STRING-TRIM function for this. (defun trim (&rest strings) (values-list (loop for string in strings collect (regex-replace #?r/^\s+/ (regex-replace #?r/\s+$/ string "") "")))) (setf string (trim string)) (setf many (multiple-value-list (apply 'trim many))) ;;;----------------------------- ;; print what's typed, but surrounded by >< symbols (loop (let ((line (read-line))) (chomp line) (format t #?">$(line)<~%"))) ;;;----------------------------- |
;;;----------------------------- (defun parse-csv (text) (let (fields) (cl-ppcre:do-register-groups (quoted unquoted) ("\"([^\"\\\\]*(?:\\\\.[^\"\\\\]*)*)\",?|([^,]+),?|," text) (push (or quoted unquoted) fields)) (nreverse fields))) ;;;----------------------------- ;; CL has no obvious equivalent to Text::ParseWords ;;;----------------------------- (defparameter *line* "XYZZY,\"\",\"O'Reilly, Inc\",\"Wall, Larry\",\"a \\\"glug\\\" bit,\",5,\"Error, Core Dumped\"") (let ((fields (parse-csv *line*))) (loop for i below (length fields) do (format t "~D : ~A~%" i (elt fields i)))) ;;0 : XYZZY ;;1 : ;;2 : O'Reilly, Inc ;;3 : Wall, Larry ;;4 : a \"glug\" bit, ;;5 : 5 ;;6 : Error, Core Dumped ;;;----------------------------- |