1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
(declaim (optimize (speed 0) (safety 3) (debug 3)))
(defpackage #:music-dispensary
(:use #:cl #:cl-log #:hunchentoot)
(:export #:music-dispensary))
(in-package #:music-dispensary)
;; ========================================================================== ;;
(defparameter *server-root* (namestring (asdf:system-relative-pathname (intern (package-name *package*)) "./"))
"The location of the web server root on the filesystem.")
;; ========================================================================== ;;
(defmacro with-gensyms (syms &body body)
`(let ,(mapcar #'(lambda (s)
`(,s (gensym)))
syms)
,@body))
(defmacro once-only ((&rest names) &body body)
(let ((gensyms (loop for n in names collect (gensym))))
`(let (,@(loop for g in gensyms collect `(,g (gensym))))
`(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
,@body)))))
(defun logger (output)
"Logs output to the cl-log log file."
(log-message :info (format nil "~a: ~a" (net.telent.date:universal-time-to-rfc2822-date (get-universal-time)) output)))
(defmacro add-to-list (output-list &rest value-to-add)
"Wraps the SETF...APPEND idiom in a smaller package."
`(setf ,output-list (append ,output-list ,@value-to-add)))
(defun match-it (regex field)
"Wraps a PCRE search in a smaller package."
(cl-ppcre:all-matches-as-strings regex field))
(defun map-slot-names (instance)
"Returns a list of the names of all the slots of any class instance
using reflection. The returned values are symbols. Only works with
SBCL. Implementations for other lisps welcome."
#+sbcl
(mapcar #'sb-mop:slot-definition-name
(sb-mop:class-slots (class-of instance))))
(defun make-document-root-path (document-root relative-path)
"Makes a relative filesystem path into a full one, using
`document-root' as the base."
(concatenate 'string document-root relative-path))
(defun make-server-path (relative-path)
"Makes a relative filesystem path into a full one, using
`*server-root*' as the base."
(make-document-root-path *server-root* relative-path))
(defun null-or-empty-p (sequence)
(or (null sequence) (equal (length sequence) 0)))
(defun shell-wrapper (command)
"Calls a shell command and returns the output as a list, where each
atom of the list is a string that contains one line of the output."
(let ((output (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t)))
(with-output-to-string (stream output)
(uffi:run-shell-command command :output stream))
(loop for line in (ppcre:split #\Newline output)
collect line)))
(defun reduce-to-char-separated-string (mylist char)
(format nil "~a" (reduce (lambda (&optional x y)
(cond ((and x y) (format nil "~a~a~a" x char y))
((and x (not y)) (format nil "~a" x))
((and (not x) y) (format nil "~a" y))
(t "")))
mylist)))
(defun reduce-to-comma-separated-string (mylist)
(reduce-to-char-separated-string mylist ","))
(defun reduce-to-newline-separated-string (mylist)
(reduce-to-char-separated-string mylist #\Newline))
|
