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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
;;;; -*- mode: lisp -*-
;;;;
;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
;;;;
;;;; This is a collection of Common Lisp utilities
;;;;
;;;; Copyright (C) 2004-2005 Sven Van Caekenberghe, Beta Nine BVBA.
;;;;
;;;; You are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser General Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
(in-package :s-utils)
(export
'(make-subdirectory
pathname-parent
copy-stream
tokens
format-universal-time
format-duration
format-iso-gmt-time
parse-integer-safely
+us-day-names+
+us-month-names+
+us-time-format+
+us-date-format+
+en-duration-unit-names+))
;; pathname/directory manipulation
(defun make-subdirectory (basedir subdir)
"Give a pathname, basedir, of a directory, create a subdirectory with name subdir"
(make-pathname :directory (append (pathname-directory basedir)
(if (listp subdir) subdir (list subdir)))))
(defun pathname-parent (pathname)
"Given a pathname, return the parent pathname"
(if (pathname-name pathname)
(make-pathname :directory (pathname-directory pathname))
(make-pathname :directory (butlast (pathname-directory pathname)))))
;; stream copying
(defun copy-stream (in out &optional (buffer (make-string 4096)) second-buffer (convertor #'identity))
"Copy all data from input stream in to output stream out using buffer (and read/write-sequence)"
;; optionally use a second-buffer of a different type matching the destination stream
;; and use the convertor function to convert elements from buffer to second-buffer
(if second-buffer
(labels ((convert-buffer (limit)
(loop :for i :below limit
:do (setf (elt second-buffer i) (funcall convertor (elt buffer i)))))
(copy-chunks ()
(let ((size (read-sequence buffer in)))
(cond ((< size (length buffer))
(convert-buffer size)
(write-sequence second-buffer out :end size))
(t
(convert-buffer (length buffer))
(write-sequence second-buffer out)
(copy-chunks))))))
(assert (= (length buffer) (length second-buffer)))
(copy-chunks))
(labels ((copy-chunks ()
(let ((size (read-sequence buffer in)))
(cond ((< size (length buffer))
(write-sequence buffer out :end size))
(t
(write-sequence buffer out)
(copy-chunks))))))
(copy-chunks))))
;; elementary parsing
(defun tokens (string &key (start 0) end (separators (list #\space #\return #\linefeed #\tab)))
"Split string in a list of tokens using separators, a list of characters"
(if (= start (length string))
'()
(let ((p (position-if #'(lambda (char) (find char separators :test #'char=))
string
:start start :end end)))
(if p
(if (= p start)
(tokens string :start (1+ start) :end end :separators separators)
(cons (subseq string start p)
(tokens string :start (1+ p) :end end :separators separators)))
(list (subseq string start end))))))
;; time/date formatting
(defparameter +us-day-names+
'("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
"US English short day name constant strings")
(defparameter +us-month-names+
'("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
"US English short month name constant strings")
(defparameter +us-time-format+
'(:day-name #\Space :month-name #\Space :date #\Space :year #\Space :hour #\: :minute #\: :second)
"US English style date-time format")
(defparameter +us-date-format+
'(:day-name #\Space :month-name #\Space :date #\Space :year)
"US English style date-only format")
(defun format-universal-time (universal-time
&key
(format +us-time-format+)
(day-names +us-day-names+)
(month-names +us-month-names+)
decode-in-timezone
stream)
"Format universal time using format, day-names and month-names, if stream is not nil use it, else return a string"
(multiple-value-bind (second minute hour date month year day daylight-p timezone)
(if decode-in-timezone
(decode-universal-time universal-time decode-in-timezone)
(decode-universal-time universal-time))
(declare (ignore daylight-p))
(flet ((two-digit (n) (format nil "~2,'0d" n)))
(let* ((month-name (elt month-names (1- month)))
(day-name (elt day-names day))
(bindings `((:second . ,(two-digit second))
(:minute . ,(two-digit minute))
(:hour . ,(two-digit hour))
(:date . ,date)
(:month . ,month)
(:year . ,year)
(:day . ,day)
(:date2 . ,(two-digit date))
(:day-name . ,day-name)
(:month-name . ,month-name)
(:timezone . ,(format nil "~c~2,'0d" (if (plusp timezone) #\+ #\-) (abs timezone)))))
(out (or stream (make-string-output-stream))))
(dolist (x format)
(format out "~a" (if (keywordp x) (cdr (assoc x bindings)) x)))
(unless stream
(get-output-stream-string out))))))
;; duration formatting
(defparameter +en-duration-unit-names+
#("year" "day" "hour" "minute" "second")
"English time duration unit name constant strings")
(defun format-duration (seconds &key (unit-names +en-duration-unit-names+) stream)
"Format seconds as duration using unit-names, if stream is not nil use it, else return a string"
(let ((out (or stream (make-string-output-stream)))
years days hours minutes did-wrote-output)
(setf years (floor seconds (* 60 60 24 365)))
(setf seconds (rem seconds (* 60 60 24 365)))
(setf days (floor seconds (* 60 60 24)))
(setf seconds (rem seconds (* 60 60 24)))
(setf hours (floor seconds (* 60 60)))
(setf seconds (rem seconds (* 60 60)))
(setf minutes (floor seconds 60))
(setf seconds (rem seconds 60))
(flet ((fmt-unit (n unit)
(unless (zerop n)
(when did-wrote-output (write-char #\space out))
(format out "~d ~a~p" n unit n)
(setf did-wrote-output t))))
(fmt-unit years (aref unit-names 0))
(fmt-unit days (aref unit-names 1))
(fmt-unit hours (aref unit-names 2))
(fmt-unit minutes (aref unit-names 3))
(fmt-unit seconds (aref unit-names 4)))
(unless stream
(get-output-stream-string out))))
;; simplified ISO date/time formatting
(defun format-iso-gmt-time (universal-time &key stream)
"Format universal time using a simple and fast 'ISO GMT' style, if stream is not nil use it, else return a string"
(let ((out (or stream (make-string-output-stream))))
(multiple-value-bind (second minute hour date month year)
(decode-universal-time universal-time 0)
(flet ((two-digit (n s) (if (< n 10)
(progn (write-char #\0 s) (write n :stream s))
(write n :stream s))))
(write year :stream out)
(two-digit month out)
(two-digit date out)
(write-char #\T out)
(two-digit hour out)
(two-digit minute out)
(two-digit second out)))
(unless stream
(get-output-stream-string out))))
;; extended integer parsing
(defun parse-integer-safely (string &key (start 0) end (radix 10) default)
"Like parse-integer, but will return default on error, accepts nil as argument"
(if (and (stringp string)
(not (zerop (- (length string) start))))
(multiple-value-bind (value terminating-position)
(parse-integer string :start start :end end :radix radix :junk-allowed t)
(if (= terminating-position (or end (length string)))
value
default))
default))
;;;; eof
|