dev/utilities.lisp

   1 (in-package #:lift)
   2
   3 (defvar *lift-debug-output* *debug-io*
   4   "Messages from LIFT will be sent to this stream. It can set to nil or
   5 to an output stream. It defaults to *debug-io*.")
   6
   7 (defvar *test-print-testsuite-names* t
   8   "If true, LIFT will print the name of each test suite to *debug-io* before it begins to run the suite. See also: *test-print-test-case-names*.")
   9
  10 (defvar *test-print-test-case-names* nil
  11   "If true, LIFT will print the name of each test-case before it runs. See also: *test-print-testsuite-names*.")
  12
  13
  14 ;; stolen from metatilities
  15 (defun form-symbol-in-package (package &rest names)
  16     "Finds or interns a symbol in package whose name is formed by concatenating the pretty printed representation of the names together."
  17     (with-standard-io-syntax
  18       (let ((*package* package))
  19         (intern (format nil "~{~a~}" names)
  20                 package))))
  21
  22 (defun form-symbol (&rest names)
  23     "Finds or interns a symbol in the current package whose name is formed by concatenating the pretty printed representation of the names together."
  24     (apply #'form-symbol-in-package *package* names))
  25
  26 (defun form-keyword (&rest names)
  27     "Finds or interns a symbol in the current package whose name is formed by concatenating the pretty printed representation of the names together."
  28     (apply #'form-symbol-in-package
  29            (load-time-value (find-package :keyword)) names))
  30
  31 ;; borrowed from asdf
  32 (defun pathname-sans-name+type (pathname)
  33   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
  34 and NIL NAME and TYPE components"
  35   (make-pathname :name nil :type nil :defaults pathname))
  36
  37 (defun pathname-has-device-p (pathname)
  38   (and (or (stringp pathname) (pathnamep pathname))
  39        (not (member (pathname-device pathname) '(nil :unspecific)))))
  40
  41 (defun pathname-has-host-p (pathname)
  42   (and (or (stringp pathname) (pathnamep pathname))
  43        (not (member (pathname-host pathname) '(nil :unspecific)))))
  44
  45 (defun relative-pathname (relative-to pathname &key name type)
  46   (let ((directory (pathname-directory pathname)))
  47     (when (eq (car directory) :absolute)
  48       (setf directory (copy-list directory)
  49             (car directory) :relative))
  50     (merge-pathnames
  51      (make-pathname :name (or name (pathname-name pathname))
  52                     :type (or type (pathname-type pathname))
  53                     :directory directory
  54                     )
  55      relative-to)))
  56
  57 (defun directory-pathname-p (p)
  58   (flet ((component-present-p (value)
  59            (and value (not (eql value :unspecific)))))
  60     (and
  61      (not (component-present-p (pathname-name p)))
  62      (not (component-present-p (pathname-type p)))
  63      p)))
  64
  65 (defun directory-p (name)
  66   (let ((truename (probe-file name)))
  67     (and truename (directory-pathname-p name))))
  68
  69 (defun containing-pathname (pathspec)
  70   "Return the containing pathname of the thing to which
  71 pathspac points. For example:
  72
  73     > \(containing-directory \"/foo/bar/bis.temp\"\)
  74     \"/foo/bar/\"
  75     > \(containing-directory \"/foo/bar/\"\)
  76     \"/foo/\"
  77 "
  78   (make-pathname
  79    :directory `(,@(butlast (pathname-directory pathspec)
  80                            (if (directory-pathname-p pathspec) 1 0)))
  81    :name nil
  82    :type nil
  83    :defaults pathspec))
  84
  85 ;; FIXME -- abstract and merge with unique-directory
  86 (defun unique-filename (pathname &optional (max-count 10000))
  87   (let ((date-part (date-stamp)))
  88     (loop repeat max-count
  89        for index from 1
  90          for name =
  91          (merge-pathnames
  92           (make-pathname
  93            :name (format nil "~a-~a-~d"
  94                          (pathname-name pathname)
  95                          date-part index))
  96           pathname) do
  97          (unless (probe-file name)
  98            (return-from unique-filename name)))
  99     (error "Unable to find unique pathname for ~a; there are already ~:d similar files" pathname max-count)))
 100
 101 ;; FIXME -- abstract and merge with unique-filename
 102 (defun unique-directory (pathname)
 103   (setf pathname (merge-pathnames pathname))
 104   (let* ((date-part (date-stamp))
 105          (last-directory (first (last (pathname-directory pathname))))
 106          (base-pathname (containing-pathname pathname))
 107          (base-name (pathname-name last-directory))
 108          (base-type (pathname-type last-directory)))
 109     (or (loop repeat 10000
 110            for index from 1
 111            for name =
 112            (merge-pathnames
 113             (make-pathname
 114              :name nil
 115              :type nil
 116              :directory `(:relative
 117                           ,(format nil "~@[~a-~]~a-~d~@[.~a~]"
 118                                    base-name date-part index base-type)))
 119             base-pathname) do
 120            (unless (probe-file name)
 121              (return name)))
 122         (error "Unable to find unique pathname for ~a" pathname))))
 123
 124 (defun date-stamp (&key (datetime (get-universal-time)) (include-time? nil)
 125                    (include-date? t)
 126                    (time-delimiter #\-) (date-delimiter #\-) (date-time-separator #\T))
 127   (multiple-value-bind
 128         (second minute hour day month year day-of-the-week)
 129       (decode-universal-time datetime)
 130     (declare (ignore day-of-the-week))
 131     (let ((date-part (format nil "~d~@[~c~]~2,'0d~@[~c~]~2,'0d"
 132                              year date-delimiter month date-delimiter day))
 133           (time-part (and include-time?
 134                           (format nil "~2,'0d~@[~c~]~2,'0d~@[~c~]~2,'0d"
 135                                   hour time-delimiter minute
 136                                   time-delimiter second))))
 137       (format nil "~@[~a~]~@[~c~]~@[~a~]"
 138               (and include-date? date-part)
 139               (and include-date? include-time? date-time-separator)
 140               (and include-time? time-part)))))
 141
 142 #-allegro
 143 (defun format-test-time-for-log (test-time)
 144   (multiple-value-bind (ut fsecs)
 145       (truncate test-time 1000)
 146     (date-stamp :datetime ut :include-date? nil :include-time? t :time-delimiter #\:)))
 147
 148 #+allegro
 149 (defun format-test-time-for-log (test-time)
 150   (multiple-value-bind (ut fsecs)
 151       (truncate test-time 1000)
 152     (with-output-to-string (out)
 153       (let* ((time
 154               (excl:locale-print-time ut :fmt "%T" :stream nil)
 155                #+no
 156                (excl:locale-print-time ut :fmt "%Y-%m-%dT%T" :stream nil)))
 157         (format out "~a.~3,'0d" time fsecs)))))
 158
 159 #+(or)
 160 (date-stamp :include-time? t)
 161
 162 ;;; ---------------------------------------------------------------------------
 163 ;;; shared stuff
 164 ;;; ---------------------------------------------------------------------------
 165
 166 (defgeneric get-class (thing &key error?)
 167   (:documentation "Returns the class of thing or nil if the class cannot be found. Thing can be a class, an object representing a class or a symbol naming a class. Get-class is like find-class only not as particular.")
 168   (:method ((thing symbol) &key error?)
 169            (find-class thing error?))
 170   (:method ((thing standard-object) &key error?)
 171            (declare (ignore error?))
 172            (class-of thing))
 173   (:method ((thing t) &key error?)
 174            (declare (ignore error?))
 175            (class-of thing))
 176   (:method ((thing class) &key error?)
 177            (declare (ignore error?))
 178            thing))
 179
 180 (defun direct-subclasses (thing)
 181   "Returns the immediate subclasses of thing. Thing can be a class, object or symbol naming a class."
 182   (class-direct-subclasses (get-class thing)))
 183
 184 (defun map-subclasses (class fn &key proper?)
 185   "Applies fn to each subclass of class. If proper? is true, then
 186 the class itself is not included in the mapping. Proper? defaults to nil."
 187   (let ((mapped (make-hash-table :test #'eq)))
 188     (labels ((mapped-p (class)
 189                (gethash class mapped))
 190              (do-it (class root)
 191                (unless (mapped-p class)
 192                  (setf (gethash class mapped) t)
 193                  (unless (and proper? root)
 194                    (funcall fn class))
 195                  (mapc (lambda (class)
 196                          (do-it class nil))
 197                        (direct-subclasses class)))))
 198       (do-it (get-class class) t))))
 199
 200 (defun subclasses (class &key (proper? t))
 201   "Returns all of the subclasses of the class including the class itself."
 202   (let ((result nil))
 203     (map-subclasses class (lambda (class)
 204                             (push class result))
 205                     :proper? proper?)
 206     (nreverse result)))
 207
 208 (defun superclasses (thing &key (proper? t))
 209   "Returns a list of superclasses of thing. Thing can be a class,
 210 object or symbol naming a class. The list of classes returned is
 211 'proper'; it does not include the class itself."
 212   (let ((result (class-precedence-list (get-class thing))))
 213     (if proper? (rest result) result)))
 214
 215 (defun class-slot-names (thing)
 216   (declare (ignorable thing))
 217   #+allegro
 218   (let ((class (get-class thing)))
 219     (if class
 220       (mapcar 'mop:slot-definition-name
 221               (mop:class-slots (finalize-class-if-necessary class)))
 222       (progn
 223         (warn "class for ~a not found)" thing)
 224         nil))))
 225
 226 (defun finalize-class-if-necessary (thing)
 227   "Finalizes thing if necessary. Thing can be a class, object or
 228 symbol naming a class. Returns the class of thing."
 229   (declare (ignorable thing))
 230   #+allegro
 231   (let ((class (get-class thing)))
 232     (unless (mop:class-finalized-p class)
 233       (mop:finalize-inheritance class))
 234     (values class)))
 235
 236 (declaim (inline length-1-list-p))
 237 (defun length-1-list-p (x)
 238   "Is x a list of length 1?"
 239   (and (consp x) (null (cdr x))))
 240
 241 (defun parse-brief-slot (slot)
 242   (let* ((slot-spec
 243           (typecase slot
 244             (symbol (list slot))
 245             (list slot)
 246             (t (error "Slot-spec must be a symbol or a list. `~s` is not."
 247                       slot)))))
 248     (unless (null (cddr slot-spec))
 249       (error "Slot-spec must be a symbol or a list of length one or two. `~s` has too many elements." slot))
 250     `(,(first slot-spec)
 251        :initarg ,(form-keyword (first slot-spec))
 252        :initform ,(when (second slot-spec) `,(second slot-spec)))))
 253
 254 (defun convert-clauses-into-lists (clauses-and-options clauses-to-convert)
 255   ;; This is useful (for me at least!) for writing macros
 256   (let ((parsed-clauses nil))
 257     (do* ((clauses clauses-and-options (rest clauses))
 258           (clause (first clauses) (first clauses)))
 259          ((null clauses))
 260       (if (and (keywordp clause)
 261                (or (null clauses-to-convert) (member clause clauses-to-convert))
 262                (not (length-1-list-p clauses)))
 263         (progn
 264           (setf clauses (rest clauses))
 265           (push (list clause (first clauses)) parsed-clauses))
 266         (push clause parsed-clauses)))
 267     (nreverse parsed-clauses)))
 268
 269 (defun remove-leading-quote (list)
 270   "Removes the first quote from a list if one is there."
 271   (if (and (consp list) (eql (first list) 'quote))
 272     (first (rest list))
 273     list))
 274
 275 (defun cleanup-parsed-parameter (parameter)
 276   (if (length-1-list-p parameter)
 277     (first parameter)
 278     parameter))
 279
 280 (defun ensure-string (it)
 281   (etypecase it
 282     (string it)
 283     (symbol (symbol-name it))))
 284
 285 (defun ensure-function (thing)
 286   (typecase thing
 287     (function thing)
 288     (symbol (symbol-function thing))))
 289
 290 (defun ensure-list (thing)
 291   (if (listp thing) thing (list thing)))
 292
 293 ;;;;
 294
 295 (defun version-numbers (version &optional padded)
 296   "Returns a list of the version numbers in a #\. delimited string of
 297 integers. E.g. (version-numbers \"2.2.1\") ==> (2 2 1). If the optional
 298 `padded` parameter is included, the length of the returned list will be
 299 right-padded with zeros so that it is of length padded (the list won't
 300 be truncated if padded is smaller than the number of version digits in
 301 the string."
 302   (let ((result (mapcar 'safe-parse-integer (split version '(#\.)))))
 303     (if padded
 304         (pad-version result padded)
 305         result)))
 306
 307 (defun canonical-versions-numbers (v-1 v-2)
 308   (let* ((v-1s (version-numbers v-1))
 309          (v-2s (version-numbers v-2))
 310          (max (max (length v-1s) (length v-2s))))
 311     (values (pad-version v-1s max) (pad-version v-2s max))))
 312
 313 (defun version= (v-1 v-2)
 314   (multiple-value-bind (v-1s v-2s)
 315       (canonical-versions-numbers v-1 v-2)
 316     (every (lambda (v1 v2) (= v1 v2))
 317            v-1s v-2s)))
 318
 319 (defun version< (v-1 v-2)
 320   (multiple-value-bind (v-1s v-2s)
 321       (canonical-versions-numbers v-1 v-2)
 322     (loop for last1 = nil then v1
 323        for last2 = nil then v2
 324        for v1 in v-1s
 325        for v2 in v-2s
 326        when (or (and (null last1) (> v1 v2))
 327                 (and (not (null last1))
 328                      (= last1 last2)
 329                      (> v1 v2))) do
 330        (return-from version< nil)
 331        when (< v1 v2) do
 332        (return-from version< t)
 333        finally
 334        ;; everything equal
 335        (when (and (not (null last1)) (= last1 last2))
 336          (return-from version< nil)))
 337     t))
 338
 339 (defun pad-version (v size)
 340   (assert (<= (length v) size))
 341   (append v (make-list (- size (length v)) :initial-element 0)))
 342
 343 (defun version<= (v-1 v-2)
 344   (or (version< v-1 v-2)
 345       (version= v-1 v-2)))
 346
 347 (defun version> (v-1 v-2)
 348   (not (version<= v-1 v-2)))
 349
 350 (defun version>= (v-1 v-2)
 351   (not (version< v-1 v-2)))
 352
 353 (defun safe-parse-integer (string)
 354   (parse-integer string :junk-allowed t))
 355
 356 (defun split (string &optional (ws '(#\Space #\Tab)))
 357   (flet ((is-ws (char) (find char ws)))
 358     (nreverse
 359      (let ((list nil) (start 0) (words 0) end)
 360        (loop
 361         (setf end (position-if #'is-ws string :start start))
 362         (push (subseq string start end) list)
 363         (incf words)
 364         (unless end (return list))
 365         (setf start (1+ end)))))))
 366
 367 ;;; whitespace-p
 368
 369 (defparameter +whitespace-characters+
 370   (list #\Space #\Newline #\Tab #\Page #\Null #\Linefeed)
 371   "A list of characters that should be treated as whitespace. See,
 372 for example, [whitespacep][].")
 373
 374 (defun whitespacep (char)
 375   "Returns true if `char` is an element of [+whitespace-characters+][]
 376 and nil otherwise."
 377   (not (null (find char +whitespace-characters+ :test #'char=))))
 378
 379 (defun string-trim-if (predicate string &key (start 0) (end (length string)))
 380   (let ((end (1- end)))
 381     (loop for ch across string
 382        while (funcall predicate ch) do (incf start))
 383     (when (< start end)
 384       (loop for ch = (aref string end)
 385          while (funcall predicate ch) do (decf end)))
 386     (subseq string start (1+ end))))
 387
 388 (defun strip-whitespace (string &key (start 0) (end (length string)))
 389   (string-trim-if
 390    #'whitespacep string :start start :end end))
 391
 392 (defun lisp-version-string ()
 393   ;; shared with many other projects... sigh
 394   #+cmu       (substitute #\- #\/
 395                           (substitute #\_ #\Space
 396                                       (lisp-implementation-version)))
 397   #+scl       (lisp-implementation-version)
 398   #+sbcl      (lisp-implementation-version)
 399   #+ecl       (reduce (lambda (x str) (substitute #\_ str x))
 400                       '(#\Space #\: #\( #\))
 401                       :initial-value (lisp-implementation-version))
 402   #+gcl       (let ((s (lisp-implementation-version))) (subseq s 4))
 403   #+openmcl   (format nil "~d.~d~@[-~d~]"
 404                       ccl::*openmcl-major-version*
 405                       ccl::*openmcl-minor-version*
 406                       #+ppc64-target 64
 407                       #-ppc64-target nil)
 408   #+lispworks (format nil "~A~@[~A~]"
 409                       (lisp-implementation-version)
 410                       (when (member :lispworks-64bit *features*) "-64bit"))
 411   #+allegro   (format nil
 412                       "~A~A~A~A"
 413                       excl::*common-lisp-version-number*
 414                                         ; ANSI vs MoDeRn
 415                       ;; thanks to Robert Goldman and Charley Cox for
 416                       ;; an improvement to my hack
 417                       (if (eq excl:*current-case-mode*
 418                               :case-sensitive-lower) "M" "A")
 419                       ;; Note if not using International ACL
 420                       ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
 421                       (excl:ics-target-case
 422                         (:-ics "8")
 423                         (:+ics ""))
 424                       (if (member :64bit *features*) "-64bit" ""))
 425   #+clisp     (let ((s (lisp-implementation-version)))
 426                 (subseq s 0 (position #\space s)))
 427   #+armedbear (lisp-implementation-version)
 428   #+cormanlisp (lisp-implementation-version)
 429   #+digitool   (subseq (lisp-implementation-version) 8))
 430
 431 (defun print-lift-message (message &rest args)
 432   (declare (dynamic-extent args))
 433   (apply #'format *lift-debug-output* message args)
 434   (force-output *lift-debug-output*))
 435
 436 (defun %start-test-case (name result)
 437   (when (and *test-print-test-case-names*
 438              (eq (test-mode result) :multiple))
 439     (if (eq *test-print-test-case-names* :brief)
 440         (print-lift-message ".")
 441         (print-lift-message "~&  run: ~a" name))))
 442
 443 (defun %start-test-suite (name result)
 444   (when (and *test-print-testsuite-names*
 445              (eq (test-mode result) :multiple))
 446     (if (eq *test-print-testsuite-names* :brief)
 447         (print-lift-message "*")
 448         (print-lift-message "~&Start: ~a" name))))
 449
 450 (defun safe-find-symbol (symbol package)
 451   (and (find-package package)
 452        (find-symbol (etypecase symbol
 453                       (string symbol)
 454                       (symbol (symbol-name symbol))) package)))
 455
 456 (defun symbol-apply (symbol package &rest args)
 457   (let* ((symbol (safe-find-symbol symbol package))
 458          (function (and symbol (symbol-function symbol))))
 459     (when function
 460       (apply function args))))
 461
 462 (defun form-groups (list size)
 463   (let ((result nil)
 464         (count 0)
 465         (sub-result nil))
 466     (flet ((add-one ()
 467              (push (nreverse sub-result) result)
 468              (setf sub-result nil count 0)))
 469       (loop for a in list do
 470            (when (= count size) (add-one))
 471            (push a sub-result)
 472            (incf count))
 473       (when (= count size) (add-one))
 474       (values (nreverse result) (nreverse sub-result)))))
 475
 476 (defun test-function-name (test-function)
 477   (cond ((eq test-function #'eq)
 478          "eq")
 479         ((eq test-function #'eql)
 480          "eql")
 481         ((eq test-function #'equal)
 482          "equal")
 483         ((eq test-function #'equalp)
 484          "equalp")
 485         ((eq test-function #'=)
 486          "=")
 487         (t
 488          (princ-to-string test-function))))
 489
 490 (defun hostname ()
 491   (or *hostname*
 492       (setf *hostname*
 493             (multiple-value-bind (r _ code)
 494                 (or (symbol-apply (symbol-name '#:run-shell-command)
 495                                   :trivial-shell "hostname -s")
 496                     (symbol-apply (symbol-name '#:command-output)
 497                                   :excl.osi "hostname -s"))
 498               (declare (ignore _))
 499               (if (/= code 0) "unknown" (first r))))))
 500
 501 (defun dotted-pair-p (putative-pair)
 502   "Returns true if and only if `putative-pair` is a dotted-list. I.e.,
 503 if `putative-pair` is a cons cell with a non-nil cdr."
 504   (and (consp putative-pair)
 505        (cdr putative-pair)
 506        (not (consp (cdr putative-pair)))))
 507
 508 (defun make-printable (thing)
 509   (cond ((dotted-pair-p thing)
 510          (cons (make-printable (car thing))
 511                (make-printable (cdr thing))))
 512         ((keywordp thing)
 513          thing)
 514         ((symbolp thing)
 515          (encode-symbol thing))
 516         ((listp thing)
 517          (mapcar #'make-printable thing))
 518         ((typep thing 'standard-object)
 519          (format nil "~a" thing))
 520         (t
 521          thing)))