On Code

svn update
(rebuild-ccl :clean t)
> (hunchentoot:start (make-instance 'hunchentoot:acceptor :port 8080 :read-timeout nil :write-timeout nil))
*search-paths*
*search-paths*
'("~/Lisp/")
(mb:load ";workfiles;cc-validate")
find-system
(mb:component . options)
:cl-ppcre
#+mudballs (mb:component (:needs :cl-ppcre))
SINGLE-FILE-SYSTEM
SYSTEM
LISP-SOURCE-FILE
(define-system :my-system (core-system-mixin system)  .....)
 (:NEEDS #-lispworks :USOCKET)
 (:NEEDS (:USOCKET (:FOR (:NOT :LISPWORKS)))) 
(COMPAT NAMED-MODULE  
  (:NAMES :ALLEGRO :CLISP :LISPWORKS
          ((:OR :MCL :OPENMCL) "mcl")  
          ((:OR :CMU :SBCL) "pcl"))  
  (:COMPONENTS "closer-mop-packages" "closer-mop"))
(:NEEDS #+sbcl :SB-BSD-SOCKETS)
(:REQUIRES (:SB-BSD-SOCKETS (:FOR :SBCL)))
"~;mudballs;test.lisp"

(merge-pathnames (make-pathname :directory '(:relative "mudballs")
                                :name "test" :type "lisp") 
                 (user-homedir-pathname))

Other Features and Changes

FEATURE: system definitions files now are automatically compiled when mudballs changes. (this includes files added using wildcard-searcher)
FEATURE: You no longer need to run sysdef:register-sysdefs when you add new systems. It is automatically run before find-system (some attempt has been made to ensure that it doesn't impact performance too heavily)
BUG FIX: (:needs (:cl-ppcre :version "1.3")) is once again valid.
UPDATE: The no-installed-component condition has been removed as it is a conceptual duplicate.
UPDATE: redefining a system no longer creates a new instance of a SYSTEM but will reset and update the currently defined one if one exists.
BUG FIX: redefining a system will not cause the system to be considered un-operated upon.
NEWS: Mudballs now waits until the last possible moment before loading system definitions, this now results in faster startup times.
And many other small changes and fixes.

The Future

Now that we've gotten the past and present out of the way lets look to the future. Mudballs, while having had a large portion of work dedicated to operating upon systems, does NOT have 'operating on systems' as it's primary goal. Mudballs is primarily about Distribution and distributing Common Lisp systems in particular, which is 
It's biggest difference to ASDF and 
a far more useful problem that needs solving.

So what does this mean? It means that mudballs users can expect, in the near future, a portion of mudballs.com dedicated to the creation of projects and the uploading of new versions of systems which will automatically provide new definition files and downloadable mudballs on mudballs.com.

This will allow any writer of Common Lisp code to upload their system and make it available (with correct version information) to the rest of the world, complete with automatically generated documentation and links to the various releases. This, not so small, feature should go along way to providing Common Lispers with something which is at least converging on CPAN.

This is all being done with one thing in mind: Repeatability.

This is currently the biggest shortcoming of the ASDF family, in that the installation of an arbitrary set of systems cannot be reliably reproduced, which makes troubleshooting library combination issues incredibly difficult; and of course the more systems you have installed the more likely it becomes that what you have will differ from a maintainer which makes having dependencies on systems an inherently risky affair.

I know I'm not the only person who's had a particular system fail only to be told by the maintainer that `It works for me` followed by a list of the versions he is using. This is typically followed by the `Vain attempt to find these exact versions` dance [1] which is all too often followed by the `I give up, hands in the air` shuffle. As it stands, ASDF and friends just do not help here and this is the situation Mudballs is intended to solve.

Mudballs primary purpose is not System Definition but Repeatable System Distribution.

As always comments and investments of time are welcome and you can reach myself and other Mudballs users at the Mudballs Google Group.

Enjoy,
 Sean.

1) Don't even get me started about systems whose primary form of distribution is `Fresh checkout from VC tool of choice`.

> (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.

(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)))))

(defun filter (test list)
 (let ((result ()))
   (dolist (elt list RESULT)
     (when (funcall test elt)
       (push elt result)))))

(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)))

         *
        * *
       * * *
      * * * *
     * * * * *
    * * * * * *
   * * * * * * *
  * * * * * * * *
 * * * * * * * * *
* * * * * * * * * *
 * * * * * * * * *
  * * * * * * * *
   * * * * * * *
    * * * * * *
     * * * * *
      * * * *
       * * *
        * *
         *

On Code

Hunchentoot and CCL on Windows. Take 2.

Hunchentoot, CCL and Windows

Mudballs 3

Mudballs Google Group

A Mudballs Update

Announcing Mudballs

Renaming files in Common Lisp.

Case Conversion Considered Useful

The 'pre Arc' Arc

Ruby Quiz 144 (in CL)

Closures + Lambda < CLOS

Lisp in Lisp

Advertising is good

Hunchentoot and packages

asdf-install & Windows

Feisty Friday

ORF and values

orf (a Common Lisp version of ||=)

Format

darjeeling

Lispworks 5.1 Personal Edition