svn updateand
(rebuild-ccl :clean t)and ignore my previous post.
> (hunchentoot:start (make-instance 'hunchentoot:acceptor :port 8080 :read-timeout nil :write-timeout nil))(mb:load ";workfiles;cc-validate")Internally a component is created in mudballs and is operated upon and can be looked up using find-system. The component which is created can be customized by adding a (mb:component . options) form to the top of the file. As an example, a small file which needs :cl-ppcre can be customized by adding the following form to the top of the file.
#+mudballs (mb:component (:needs :cl-ppcre))It is worth noting that SINGLE-FILE-SYSTEM is not, in fact, a subclass of SYSTEM but rather a subclass of LISP-SOURCE-FILE.
(define-system :my-system (core-system-mixin system) .....)Will create a new system which extends both core-system-mixin and system.
(:NEEDS #-lispworks :USOCKET)Using :FOR (which is now the preferred approach) the :NEEDS form will now look like this.
(:NEEDS (:USOCKET (:FOR (:NOT :LISPWORKS))))Granted this is somewhat more verbose (although somewhat less so when replacing a #+ conditionalization) it does mean that the system dependencies are now portably inspectable. This option is applicable to ALL instances of components, including modules and files. It is also worth noting the value for the FOR option can be anything which is suitable to sysdef::featurep.
(COMPAT NAMED-MODULEEach entry in the :NAMES option is expected to be either a symbol which, when matched using featurep, will use the string-downcase'd version of the symbol as the directory name. When a list is provided then the first element in the list is the argument which will be tested using featurep and the second is the name to use if it matches.
(:NAMES :ALLEGRO :CLISP :LISPWORKS
((:OR :MCL :OPENMCL) "mcl")
((:OR :CMU :SBCL) "pcl"))
(:COMPONENTS "closer-mop-packages" "closer-mop"))
(:NEEDS #+sbcl :SB-BSD-SOCKETS)option. This is now replaced by
(:REQUIRES (:SB-BSD-SOCKETS (:FOR :SBCL)))
(merge-pathnames (make-pathname :directory '(:relative "mudballs")
:name "test" :type "lisp")
(user-homedir-pathname))
> (mb:install :hunchentoot)
> (hunchentoot:start-server :port 8080)
P.S. Prizes for anyone that can come up with a logo which doesn't look like a pile of excrement.
So I ran across this while going through my morning catchup routine and thought it could do with some clearing up.
The part of the post I'm actually interested is this.
When Haskell can compete on those types of problems, it'll be easier to induce people to learn it. (Same with CL, my fav language....)
Now, bonus points for proclaiming CL as being his favorite language, but minus 10 billion for continuing the meme
One of the examples given is "I have a bunch of files, and I want to rename them all according to some pattern." and as it so happens translate-pathname[2] makes this wonderfully simple.
(defun rename-files (from to)
(dolist (file (directory from))
(rename-file file (translate-pathname file from to))))
(defun show-rename-files (from to)
(dolist (file (directory from))
(format t "Renaming ~A to ~A~%" file
(translate-pathname file from to))))
(show-rename-files "/usr/share/pixmaps/*.xpm" "/usr/share/pixmaps/backup-*.xpm")
(defun filter (test list)
(let ((result ()))
(dolist (elt list result)
(when (funcall test elt)
(push elt result)))))
the result form 'leaps' out of the page which makes it very difficult to miss.
(defun filter (test list)
(let ((result ()))
(dolist (elt list RESULT)
(when (funcall test elt)
(push elt result)))))
1: Stranger, as in, 'This isn't like C/Java/Python/Ruby'.
2: This is only the default and can be changed using readtable-case
3: Well it happens to me, ok.
This was actually the Lisp that I cut my teeth on way back in 2001 (Grief, I can't believe it was that long ago) and looking back on it brings back some fond memories and reminds me how full featured it was (especially for something at version 0.17), to list some of them:
and Most importantly it has apropos, god knows why arc is missing this.
(defpackage :time-window (:use :cl :cl-ppcre :alexandria)
(:export #:in-window-p))
(in-package :time-window)
;(defparameter *window* "Sat-Mon; Mon Wed 0700-0900; Thu 0700-0900 1000-1200")
;; This works by converting a spec (like the one above) into it's seperate components (split by ;)
;; and converting each spec into distinct time and day parts (expanding day ranges as we go)
;; so the above would be converted into the following
;; ((nil ("Sat" "Sun" "Mon"))
;; (("0700-0900") ("Mon" "Wed"))
;; (("0700-0900" "1000-1200") ("Thu")))
;; We can then walk through each converted spec ensuring that the time specified falls into
;; the time/day specified.
(defun in-window-p (time window)
(some (lambda (spec)
(every (lambda (part)
(if (null part)
t ;; since (some (constantly t) ()) is nil
(some (curry 'time-within time) part)))
spec))
(mapcar (lambda (split)
(group-by-type (split " " (string-trim " " split))))
(split ";" window))))
(defun group-by-type (list)
(loop for spec in list
:when (time-range-p spec) :collect spec :into times
:when (single-day-p spec) :collect spec :into days
:when (day-range-p spec) :append (days-of spec) :into days
:finally (return (list times days))))
(defparameter *days*
'(("Mon" . 0) ("Tue" . 1) ("Wed" . 2) ("Thu" . 3) ("Fri" . 4) ("Sat" . 5) ("Sun" . 6)))
(defparameter *day-ring* (let ((list (copy-list *days*)))
(setf (cdr (last list)) list)
list))
(defun single-day-p (spec)
(assoc spec *days* :test 'string=))
(defun day<-spec (spec)
(cdr (single-day-p spec)))
(defun day-range-p (spec)
(and (= (count #\- spec) 1)
(every 'single-day-p (split "-" spec))))
(defun days-of (spec)
(assert (day-range-p spec))
(destructuring-bind (start stop) (split "-" spec)
(loop :for (day . nil) :in (member start *day-ring* :key 'first :test 'string=)
:collect day
:until (string= day stop))))
(defun single-time-p (spec)
(every 'digit-char-p spec))
(defun time-range-p (spec)
(and (= 1 (count #\- spec))
(every 'single-time-p (split "-" spec))))
(defun time-in-range (hour minute start stop)
(flet ((to-mins (x) (+ (* 60 (parse-integer (subseq x 0 2)))
(parse-integer (subseq x 2 4)))))
(<= (to-mins start) (+ (* 60 hour) minute) (1- (to-mins stop)))))
(defun time-within (time spec)
(multiple-value-bind (sec minute hour date month year day)
(decode-universal-time time 0)
(declare (ignore sec date month year))
(cond ((single-day-p spec) (= day (day<-spec spec)))
((time-range-p spec)
(apply #'time-in-range hour minute (split "-" spec))))))
;;; and a small test package
(defpackage :time-window.tests (:use :time-window :lisp-unit :cl))
(in-package :time-window.tests)
;; Tests
(define-test window-tests
(let ((window "Sat-Sun; Mon Wed 0700-0900; Thu 0700-0900 1000-1200"))
(flet ((in (sec hour date month year)
(in-window-p (encode-universal-time 0 sec hour date month year 0) window)))
(assert-false (in 0 8 25 9 2007))
(assert-true (in 0 8 26 9 2007))
(assert-false (in 0 11 26 9 2007))
(assert-false (in 59 6 27 9 2007))
(assert-true (in 0 7 27 9 2007))
(assert-true (in 59 8 27 9 2007))
(assert-false (in 0 9 27 9 2007))
(assert-true (in 0 11 27 9 2007))
(assert-true (in 0 11 29 9 2007))
(assert-true (in 0 0 29 9 2007))
(assert-true (in 59 23 29 9 2007))
)))
(define-test window-tests2
(let ((window "Fri-Mon"))
(flet ((in (date month year)
(in-window-p (encode-universal-time 0 0 0 date month year 0) window)))
(assert-false (in 27 9 2007))
(assert-true (in 28 9 2007))
(assert-true (in 29 9 2007))
(assert-true (in 30 9 2007))
(assert-true (in 1 10 2007))
(assert-false (in 2 10 2007)))))
(run-tests)
(defvar *handlers* () "Alist of condition name to handler")
(defvar *old-handlers* () "Var to save the bindings of *handlers*")
(defclass root-error ()
((message :initarg :message :accessor message-of :initform "Unknown"))
(:documentation "Our base error class."))
(defun raise (class text)
"signals an error of class CLASS with message TEXT."
(let ((handler (get-handler class)))
(if handler
(invoke-handler handler (make-instance class :message text))
;; This is our 'we crash now'
(error text))))
;; We implement our handlers as functions.
(defun invoke-handler (handler class)
(funcall handler class))
(defun get-handler (class)
"Finds the first handler on *handlers* which is registered with a class
which CLASS is a subtype of."
(cdr (find-if (lambda (handler) (subtypep class handler))
*handlers* :key 'car)))
(defun add-handlers (&rest handlers)
"Takes a list of (class . handler) forms and creates a new
list which can be used as *handlers*"
(append handlers *handlers*))
;;; And all that is left now is to implement trycatch
(defmacro trycatch (form &body error-bindings)
(let* ((block (gensym "BLOCK"))
;; turns each handler into a list of (tmpvar classname handler-fn)
;; its important that we save the state of *handlers* to prevent
;; using the handler bindings we are a part of if we signal an error
;; from within a handler.
(binds (loop for (name args . body) in error-bindings
collect (list (gensym) name `(lambda ,args
(let ((*handlers* *old-handlers*))
(return-from ,block (progn ,@body))))))))
`(block ,block
(let* ((*old-handlers* *handlers*)
;; binds our tmpvar to the handler-function
,@(mapcar (lambda (bind) (list (first bind) (third bind)))
binds))
;; and add (classname . handler-fn) to *handlers*
(let ((*handlers* (add-handlers ,@(mapcar (lambda (bind)
`(cons ',(second bind) ,(first bind)))
binds))))
,form)))))
;and we now raise and catch errors
(trycatch (raise 'root-error "foo")
(root-error (c) (format t "WE GOT AN ERROR ~A" c)))
(defclass my-error (root-error) ())
(defun test-my-error () (raise 'my-error "Whoops!~%"))
(trycatch (test-my-error)
(my-error (c) (format t "Great it works!~%")))
(trycatch (test-my-error)
(root-error (c) (format t "And subtyping works too~%")))
(trycatch (trycatch (test-my-error)
(root-error (c) (raise 'my-error "new-error"))
(my-error (c) "INNER MY-ERROR HANDLER"))
(my-error (c) "OUTER MY-ERROR HANDLER"))
;; should return "OUTER MY-ERROR HANDLER"
(asdf:oos 'asdf:load-op :hunchentoot)
(asdf:oos 'asdf:load-op :cl-who)
(defpackage :pack-test (:use :cl :hunchentoot :cl-who))
(in-package :pack-test)
(defun index ()
#'(lambda ()
(with-html-output-to-string (x)
(:html "The index page"))))
(defun seq-last (seq)
(aref seq (1- (length seq))))
(defun string->handler (string package)
(when (string= string "/") (return-from string->handler (index)))
(multiple-value-bind (sym type) (find-symbol string package)
(when (and (not (eql type :inherited))
(fboundp sym))
(symbol-function sym))))
(defun create-package-dispatcher (prefix)
(check-type prefix string)
(assert (eql (seq-last prefix) #\/) (prefix) "Prefix must end in a / (forward slash)")
#'(lambda (request)
(let* ((function (script-name request))
(mismatch (mismatch (script-name request) prefix
:test #'char=)))
(when (or (null mismatch)
(>= mismatch (length prefix)))
(string->handler (string-upcase (subseq function (1- (length prefix))))
*package*)))))
(push (create-package-dispatcher "/test/") *dispatch-table*)
(defun /index ()
(with-html-output-to-string (out)
(:html (:head (:title "Welcome"))
(:body (:h2 "This is my welcome page")))))
(defvar *server* (start-server :port 8080))
(asdf:oos 'asdf:load-op :gzip-stream)
(asdf:oos 'asdf:load-op :archive :version "0.6")
(defun asdf-install-extractor (to-dir tarball)
(let ((name nil))
(gzip-stream:with-open-gzip-file (ins tarball)
(archive:with-open-archive (archive ins)
(let ((*default-pathname-defaults* (pathname to-dir)))
(archive:do-archive-entries (entry archive name)
(archive:extract-entry archive entry)
(unless name (setf name (archive:name entry)))))))
;; we use string instead of namestring because
;; asdf-install searches for /'s and not \'s
;; which will break on windows
(string name)))
(push 'asdf-install-extractor asdf-install:*tar-extractors*)
(let ((a 1)
b
(c 3))
(orf (values a b c) (values 4 2 5))
(values a b c))
=> 1,2,3
(defmacro orf (place value-form &environment env)
(multiple-value-bind (vars vals store-vars writer reader)
(get-setf-expansion place env)
(let ((tmp-var (loop repeat (length store-vars) collect (gensym))))
`(let* (,@(mapcar 'list vars vals))
(multiple-value-bind ,store-vars ,reader
(multiple-value-bind ,tmp-var ,value-form
,@(loop for store in store-vars for val in tmp-var
collect `(unless ,store (setf ,store ,val)))
,writer))))))
(defmacro orf (place value &environment env)
(multiple-value-bind (vars vals store-vars writer reader)
(get-setf-expansion place env)
`(let* (,@(mapcar 'list vars vals)
(,@store-vars (or ,reader ,value)))
,writer)))
(defun print-diamond (str x &optional c a (max (1+ x)) (star "*"))
(format str "~&~[~:;~:*~vT~v@{~A ~:*~}~3@*~v,v/print-diamond/~:*~v[~:;~@*~vT~v@{~A ~:*~}~%~]~]"
x (- max x) star max star (1- x)))
(print-diamond t 10)
*
* *
* * *
* * * *
* * * * *
* * * * * *
* * * * * * *
* * * * * * * *
* * * * * * * * *
* * * * * * * * * *
* * * * * * * * *
* * * * * * * *
* * * * * * *
* * * * * *
* * * * *
* * * *
* * *
* *
*