Coverage report: /home/ellis/comp/core/lib/obj/time/local.lisp

Kind	Covered	All	%
expression	954	2950	32.3
branch	53	286	18.5

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; lib/obj/time/local.lisp --- Local Time

2

3

;; from https://github.com/dlowe-net/local-time

4

5

;;; Commentary:

6

7

;; This file encodes 'human-readable' types into CLOS objects. Objects

8

;; include timestamps, timezones and dates.

9

10

;; This file doesn't explicitly encode durations (difference between

11

;; time objects).

12

13

;;; Code:

14

(in-package :obj/time)

15

16

;;; Types

17

(defclass timestamp ()

18

((day :accessor day-of :initarg :day :initform 0 :type (unsigned-byte 16))

19

(sec :accessor sec-of :initarg :sec :initform 0 :type (unsigned-byte 16))

20

(nsec :accessor nsec-of :initarg :nsec :initform 0 :type (integer 0 999999999))))

21

22

(defstruct subzone

23

(abbrev nil)

24

(offset nil)

25

(daylight-p nil))

26

27

(defstruct timezone

28

(transitions #(0) :type simple-vector)

29

(indexes #(0) :type simple-vector)

30

(subzones #() :type simple-vector)

31

(leap-seconds nil :type list)

32

(path nil)

33

(name "anonymous" :type string)

34

(loaded nil :type boolean))

35

36

(eval-when (:compile-toplevel :load-toplevel :execute)

37

(defconstant +timezone-offset-min+ -86400)

38

(defconstant +timezone-offset-max+ 86400))

39

40

(deftype timezone-offset ()

41

'(integer #.+timezone-offset-min+ #.+timezone-offset-max+))

42

43

(defun %valid-time-of-day? (timestamp)

44

(zerop (day-of timestamp)))

45

46

(deftype time-of-day ()

47

'(and timestamp

48

(satisfies %valid-time-of-day?)))

49

50

(defun %valid-date? (timestamp)

51

(and (zerop (sec-of timestamp))

52

(zerop (nsec-of timestamp))))

53

54

(deftype date ()

55

'(and timestamp

56

(satisfies %valid-date?)))

57

58

(defun zone-name (zone)

59

(timezone-name zone))

60

61

(define-condition invalid-timezone-file (error)

62

((path :accessor path-of :initarg :path))

63

(:report (lambda (condition stream)

64

(format stream "The file at ~a is not a timezone file."

65

(path-of condition)))))

66

67

(define-condition invalid-time-specification (error)

68

()

69

(:report "The time specification is invalid"))

70

71

(define-condition invalid-timestring (error)

72

((timestring :accessor timestring-of :initarg :timestring)

73

(failure :accessor failure-of :initarg :failure))

74

(:report (lambda (condition stream)

75

(format stream "Failed to parse ~S as an rfc3339 time: ~S"

76

(timestring-of condition)

77

(failure-of condition)))))

78

79

(defmethod make-load-form ((self timestamp) &optional environment)

80

(make-load-form-saving-slots self :environment environment))

81

82

;;; Declaims

83

84

(declaim (inline now format-timestring %get-current-time

85

format-rfc3339-timestring to-rfc3339-timestring

86

format-rfc1123-timestring to-rfc1123-timestring)

87

(ftype (function (&rest t) string) format-rfc3339-timestring)

88

(ftype (function (&rest t) string) format-timestring)

89

(ftype (function (&rest t) fixnum) local-timezone)

90

(ftype (function (&rest t) (values

91

timezone-offset

92

boolean

93

string)) timestamp-subzone)

94

(ftype (function (timestamp &key (:timezone timezone) (:offset (or null integer)))

95

(values (integer 0 999999999)

96

(integer 0 59)

97

(integer 0 59)

98

(integer 0 23)

99

(integer 1 31)

100

(integer 1 12)

101

(integer -1000000 1000000)

102

(integer 0 6)

103

t

104

timezone-offset

105

simple-string))

106

decode-timestamp))

107

108

;;; Variables

109

110

(defvar *default-timezone*)

111

112

(defparameter *default-timezone-repository-path*

113

(flet ((try (project-home-directory)

114

(when project-home-directory

115

(ignore-errors

116

(truename

117

(merge-pathnames "zoneinfo/"

118

                                  (make-pathname :directory (pathname-directory project-home-directory))))))))

119

(or (when (find-package "ASDF")

120

(let ((path (eval (read-from-string

121

"(let ((system (asdf:find-system :obj/time nil)))

122

(when system

123

(asdf:component-pathname system)))"))))

124

(try path)))

125

(let ((path #.(or *compile-file-truename*

126

'*load-truename*)))

127

(when path

128

(try (merge-pathnames "../" path)))))))

129

130

;;; Month information

131

(defparameter +month-names+

132

#("" "January" "February" "March" "April" "May" "June" "July" "August"

133

"September" "October" "November" "December"))

134

(defparameter +short-month-names+

135

#("" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"

136

"Dec"))

137

(defparameter +day-names+

138

#("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))

139

(defparameter +day-names-as-keywords+

140

#(:sunday :monday :tuesday :wednesday :thursday :friday :saturday))

141

(defparameter +short-day-names+

142

#("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))

143

(defparameter +minimal-day-names+

144

#("Su" "Mo" "Tu" "We" "Th" "Fr" "Sa"))

145

146

(eval-when (:compile-toplevel :load-toplevel :execute)

147

(defconstant +months-per-year+ 12)

148

(defconstant +days-per-week+ 7)

149

(defconstant +hours-per-day+ 24)

150

(defconstant +minutes-per-day+ 1440)

151

(defconstant +minutes-per-hour+ 60)

152

(defconstant +seconds-per-day+ 86400)

153

(defconstant +seconds-per-hour+ 3600)

154

(defconstant +seconds-per-minute+ 60)

155

(defconstant +usecs-per-day+ 86400000000))

156

157

(defparameter +iso-8601-date-format+

158

'((:year 4) #\- (:month 2) #\- (:day 2)))

159

160

(defparameter +iso-8601-time-format+

161

'((:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:usec 6)))

162

163

(defparameter +iso-8601-format+

164

;; 2008-11-18T02:32:00.586931+01:00

165

(append +iso-8601-date-format+ (list #\T) +iso-8601-time-format+ (list :gmt-offset-or-z)))

166

167

(defparameter +rfc3339-format+ +iso-8601-format+)

168

169

(defparameter +rfc3339-format/date-only+

170

'((:year 4) #\- (:month 2) #\- (:day 2)))

171

172

(defparameter +asctime-format+

173

'(:short-weekday #\space :short-month #\space (:day 2 #\space) #\space

174

(:hour 2) #\: (:min 2) #\: (:sec 2) #\space

175

(:year 4)))

176

177

(defparameter +rfc-1123-format+

178

;; Sun, 06 Nov 1994 08:49:37 GMT

179

'(:short-weekday ", " (:day 2) #\space :short-month #\space (:year 4) #\space

180

(:hour 2) #\: (:min 2) #\: (:sec 2) #\space :gmt-offset-hhmm)

181

"See the RFC 1123 for the details about the possible values of the timezone field.")

182

183

(defparameter +iso-week-date-format+

184

;; 2009-W53-5

185

'((:iso-week-year 4) #\- #\W (:iso-week-number 2) #\- (:iso-week-day 1)))

186

187

(eval-when (:compile-toplevel :load-toplevel :execute)

188

(defparameter +rotated-month-days-without-leap-day+

189

#.(coerce #(31 30 31 30 31 31 30 31 30 31 31 28)

190

'(simple-array fixnum (*))))

191

192

(defparameter +rotated-month-offsets-without-leap-day+

193

(coerce

194

(cons 0

195

(loop with sum = 0

196

for days :across +rotated-month-days-without-leap-day+

197

collect (incf sum days)))

198

'(simple-array fixnum (*)))))

199

200

;; The astronomical julian date offset is the number of days between

201

;; the current date and -4713-01-01T00:00:00+00:00

202

(defparameter +astronomical-julian-date-offset+ -2451605)

203

204

;; The modified julian date is the number of days between the current

205

;; date and 1858-11-17T12:00:00+00:00. TODO: For the sake of simplicity,

206

;; we currently just do the date arithmetic and don't adjust for the

207

;; time of day.

208

(defparameter +modified-julian-date-offset+ -51604)

209

210

(defun transition-position (needle haystack)

211

(declare (type integer needle)

212

(type (simple-array integer (*)) haystack)

213

(optimize (speed 3)))

214

(loop

215

with start fixnum = 0

216

with end fixnum = (length haystack)

217

;; Invariant: haystack[start-1] <= needle < haystack[end]

218

for middle fixnum = (floor (+ end start) 2)

219

while (< start end)

220

do (if (< needle (elt haystack middle))

221

(setf end middle)

222

(setf start (1+ middle)))

223

finally

224

(return (1- start))))

225

226

(defvar *strict-first-subzone-validity*

227

nil

228

"When true, raise an error if trying to get an offset before the first

229

known transition.")

230

231

(defun %subzone-as-of (timezone seconds days &optional guess-p)

232

"TIMEZONE is a realized timezone; SECONDS and DAYS are 'timestamp-values'

233

describing a local time, or null to ask for the subzone after the last

234

transition. Return the applicable subzone and the transition-index for that

235

subzone.

236

When GUESS-P is true, the request is about SECONDS and DAYS in a timezone

237

which may not be UTC, and therefore the unix-time derived from SECONDS and

238

DAYS has an offset with respect to UTC: the offset of the subzone to be

239

found."

240

(let* ((indexes (timezone-indexes timezone))

241

(index-length (length indexes))

242

(subzones (timezone-subzones timezone)))

243

(cond ((zerop index-length)

244

(values (elt subzones 0) nil))

245

((not seconds)

246

(let ((transition-idx (1- index-length)))

247

(values (elt subzones (elt indexes transition-idx))

248

transition-idx)))

249

(t

250

(let* ((transitions (timezone-transitions timezone))

251

(unix-time (timestamp-values-to-unix seconds days))

252

(transition-idx

253

(transition-position (if guess-p

254

(- unix-time 86400)

255

unix-time)

256

transitions))

257

(subzone (elt subzones (elt indexes (max 0 transition-idx)))))

258

;; Decide what to do when unix-time is before the first transition

259

(cond ((<= 0 transition-idx))

260

((and *strict-first-subzone-validity*

261

(< (if guess-p

262

(- unix-time (subzone-offset subzone))

263

unix-time)

264

(elt transitions 0)))

265

(error "Dates before ~A are not defined in ~A"

266

(multiple-value-list (decode-universal-time

267

                                                  (timestamp-to-universal

268

                                                   (unix-to-timestamp unix-time))

269

0))

270

timezone))

271

(t (setf transition-idx 0)))

272

(when (and guess-p

273

(< transition-idx (1- index-length))) ;there is a next

274

(let* ((next-idx (1+ transition-idx))

275

(delta (- (elt transitions next-idx) unix-time)))

276

(when (<= delta 86400) ;check next offset

277

(let ((next-subzone (elt subzones (elt indexes next-idx))))

278

(when (<= (+ delta (subzone-offset next-subzone)) 0)

279

;; The next transition is valid

280

(setf transition-idx next-idx

281

subzone next-subzone))))))

282

(values subzone

283

transition-idx))))))

284

285

(defun %read-binary-integer (stream byte-count &optional (signed nil))

286

   "Read BYTE-COUNT bytes from the binary stream STREAM, and return an integer which is its representation in network byte order (MSB).  If SIGNED is true, interprets the most significant bit as a sign indicator."

287

(loop

288

:with result = 0

289

:for offset :from (* (1- byte-count) 8) :downto 0 :by 8

290

:do (setf (ldb (byte 8 offset) result) (read-byte stream))

291

:finally (if signed

292

(let ((high-bit (* byte-count 8)))

293

(if (logbitp (1- high-bit) result)

294

(return (- result (ash 1 high-bit)))

295

(return result)))

296

(return result))))

297

298

(defun %string-from-unsigned-byte-vector (vector offset)

299

   "Returns a string created from the vector of unsigned bytes VECTOR starting at OFFSET which is terminated by a 0."

300

(declare (type (vector (unsigned-byte 8)) vector))

301

(let* ((null-pos (or (position 0 vector :start offset) (length vector)))

302

(result (make-string (- null-pos offset))))

303

(loop for input-index :from offset :upto (1- null-pos)

304

for output-index :upfrom 0

305

do (setf (aref result output-index) (code-char (aref vector input-index))))

306

result))

307

308

(defun %find-first-std-offset (timezone-indexes timestamp-info)

309

(let ((subzone-idx (find-if 'subzone-daylight-p

310

timezone-indexes

311

:key (lambda (x) (aref timestamp-info x)))))

312

(subzone-offset (aref timestamp-info (or subzone-idx 0)))))

313

314

(defun %tz-verify-magic-number (inf zone)

315

;; read and verify magic number

316

(let ((magic-buf (make-array 4 :element-type 'unsigned-byte)))

317

(read-sequence magic-buf inf :start 0 :end 4)

318

(when (string/= (map 'string #'code-char magic-buf) "TZif" :end1 4)

319

(error 'invalid-timezone-file :path (timezone-path zone))))

320

;; skip 16 bytes for "future use"

321

(let ((ignore-buf (make-array 16 :element-type 'unsigned-byte)))

322

(read-sequence ignore-buf inf :start 0 :end 16)))

323

324

(defun %tz-read-header (inf)

325

`(:utc-count ,(%read-binary-integer inf 4)

326

:wall-count ,(%read-binary-integer inf 4)

327

:leap-count ,(%read-binary-integer inf 4)

328

:transition-count ,(%read-binary-integer inf 4)

329

:type-count ,(%read-binary-integer inf 4)

330

:abbrev-length ,(%read-binary-integer inf 4)))

331

332

(defun %tz-read-transitions (inf count)

333

(make-array count

334

:initial-contents

335

(loop for idx from 1 upto count

336

collect (%read-binary-integer inf 4 t))))

337

338

(defun %tz-read-indexes (inf count)

339

(make-array count

340

:initial-contents

341

(loop for idx from 1 upto count

342

collect (%read-binary-integer inf 1))))

343

344

(defun %tz-read-subzone (inf count)

345

(loop for idx from 1 upto count

346

collect (list (%read-binary-integer inf 4 t)

347

(%read-binary-integer inf 1)

348

(%read-binary-integer inf 1))))

349

350

(defun leap-seconds-sec (leap-seconds)

351

(car leap-seconds))

352

(defun leap-seconds-adjustment (leap-seconds)

353

(cdr leap-seconds))

354

355

(defun %tz-read-leap-seconds (inf count)

356

(when (plusp count)

357

(loop for idx from 1 upto count

358

collect (%read-binary-integer inf 4) into sec

359

collect (%read-binary-integer inf 4) into adjustment

360

finally (return (cons (make-array count :initial-contents sec)

361

                                 (make-array count :initial-contents adjustment))))))

362

363

(defun %tz-read-abbrevs (inf length)

364

(let ((a (make-array length :element-type '(unsigned-byte 8))))

365

(read-sequence a inf

366

:start 0

367

:end length)

368

a))

369

370

(defun %tz-read-indicators (inf length)

371

;; read standard/wall indicators

372

(let ((buf (make-array length :element-type '(unsigned-byte 8))))

373

(read-sequence buf inf

374

:start 0

375

:end length)

376

(make-array length

377

:element-type 'bit

378

:initial-contents buf)))

379

380

(defun %tz-make-subzones (raw-info abbrevs gmt-indicators std-indicators)

381

(declare (ignore gmt-indicators std-indicators))

382

;; TODO: handle TZ environment variables, which use the gmt and std

383

;; indicators

384

(make-array (length raw-info)

385

:element-type 'subzone

386

:initial-contents

387

(loop for info in raw-info collect

388

(make-subzone

389

:offset (first info)

390

:daylight-p (/= (second info) 0)

391

:abbrev (%string-from-unsigned-byte-vector abbrevs (third info))))))

392

393

(defun %realize-timezone (zone &optional reload)

394

   "If timezone has not already been loaded or RELOAD is non-NIL, loads the timezone information from its associated unix file.  If the file is not a valid timezone file, the condition INVALID-TIMEZONE-FILE will be signaled."

395

(when (or reload (not (timezone-loaded zone)))

396

(with-open-file (inf (timezone-path zone)

397

:direction :input

398

:element-type 'unsigned-byte)

399

(%tz-verify-magic-number inf zone)

400

401

;; read header values

402

(let* ((header (%tz-read-header inf))

403

(timezone-transitions (%tz-read-transitions inf (getf header :transition-count)))

404

(subzone-indexes (%tz-read-indexes inf (getf header :transition-count)))

405

(subzone-raw-info (%tz-read-subzone inf (getf header :type-count)))

406

(abbreviation-buf (%tz-read-abbrevs inf (getf header :abbrev-length)))

407

(leap-second-info (%tz-read-leap-seconds inf (getf header :leap-count)))

408

(std-indicators (%tz-read-indicators inf (getf header :wall-count)))

409

(gmt-indicators (%tz-read-indicators inf (getf header :utc-count)))

410

(subzone-info (%tz-make-subzones subzone-raw-info

411

abbreviation-buf

412

gmt-indicators

413

std-indicators)))

414

415

(setf (timezone-transitions zone) timezone-transitions)

416

(setf (timezone-indexes zone) subzone-indexes)

417

(setf (timezone-subzones zone) subzone-info)

418

(setf (timezone-leap-seconds zone) leap-second-info))

419

(setf (timezone-loaded zone) t)))

420

zone)

421

422

(eval-when (:compile-toplevel :load-toplevel :execute)

423

(defun %make-simple-timezone (name abbrev offset)

424

(let ((subzone (obj/time::make-subzone :offset offset

425

:daylight-p nil

426

:abbrev abbrev)))

427

(obj/time::make-timezone

428

:subzones (make-array 1 :initial-contents (list subzone))

429

:path nil

430

:name name

431

:loaded t)))

432

433

;; to be used as #+#.(obj/time::package-with-symbol? "SB-EXT" "GET-TIME-OF-DAY")

434

(defun package-with-symbol? (package name)

435

(if (and (find-package package)

436

(find-symbol name package))

437

'(:and)

438

'(:or))))

439

440

(defparameter +utc-zone+ (%make-simple-timezone "Coordinated Universal Time" "UTC" 0))

441

442

(defparameter +gmt-zone+ (%make-simple-timezone "Greenwich Mean Time" "GMT" 0))

443

444

(defparameter +none-zone+ (%make-simple-timezone "Explicit Offset Given" "NONE" 0))

445

446

(defparameter *location-name->timezone*

447

(make-hash-table :test 'equal

448

#+sbcl :synchronized #+sbcl t)

449

"A hashtable with entries like \"Europe/Budapest\" -> timezone-instance")

450

451

(defparameter *abbreviated-subzone-name->timezone-list*

452

(make-hash-table :test 'equal

453

#+sbcl :synchronized #+sbcl t)

454

"A hashtable of \"CEST\" -> list of timezones with \"CEST\" subzone")

455

456

(defmacro define-timezone (zone-name zone-file &key (load nil))

457

"Define zone-name (a symbol or a string) as a new timezone,

458

lazy-loaded from zone-file (a pathname designator relative to the

459

zoneinfo directory on this system. If load is true, load immediately."

460

(declare (type (or string symbol) zone-name))

461

(let ((zone-sym (if (symbolp zone-name)

462

zone-name

463

(intern zone-name))))

464

`(progn

465

(defparameter ,zone-sym

466

(make-timezone :path ,zone-file

467

:name ,(if (symbolp zone-name)

468

(string-downcase (symbol-name zone-name))

469

zone-name)))

470

,@(when load

471

`((let ((timezone (%realize-timezone ,zone-sym)))

472

(setf (gethash (timezone-name timezone)

473

*location-name->timezone*)

474

timezone)

475

(loop for subzone across (timezone-subzones timezone)

476

do

477

(push timezone

478

(gethash (subzone-abbrev subzone)

479

                                        *abbreviated-subzone-name->timezone-list*))))))

480

,zone-sym)))

481

482

(eval-when (:load-toplevel :execute)

483

(let ((default-timezone-file #p"/etc/localtime"))

484

(handler-case

485

(define-timezone *default-timezone* default-timezone-file :load t)

486

(t ()

487

(setf *default-timezone* +utc-zone+)))))

488

489

(defun find-timezone-by-location-name (name)

490

(when (zerop (hash-table-count *location-name->timezone*))

491

     (error "Seems like the timezone repository has not yet been loaded. Hint: see REREAD-TIMEZONE-REPOSITORY."))

492

(gethash name *location-name->timezone*))

493

494

495

(defun timezones-matching-subzone (abbreviated-name timestamp)

496

"Returns list of lists of active timezone, matched subzone and last transition time

497

    for timezones that have subzone matching specified ABBREVIATED-NAME as of TIMESTAMP moment if provided. "

498

(loop for zone in (gethash abbreviated-name *abbreviated-subzone-name->timezone-list*)

499

;; get the subzone and the latest transition index

500

         for (subzone transition-idx) = (multiple-value-list (%subzone-as-of zone (sec-of timestamp) (day-of timestamp)))

501

if (equal abbreviated-name (subzone-abbrev subzone))

502

           collect (list zone subzone (when transition-idx (elt (timezone-transitions zone) transition-idx)))))

503

504

(defun all-timezones-matching-subzone (abbreviated-name)

505

"Returns list of lists of timezone, matched subzone and last transition time

506

    for timezones that have subzone matching specified ABBREVIATED-NAME. Includes both active and historical timezones."

507

(loop for zone in (gethash abbreviated-name *abbreviated-subzone-name->timezone-list*)

508

for (subzone transition-idx) = (multiple-value-list (%subzone-as-of zone nil nil))

509

if (equal abbreviated-name (subzone-abbrev subzone))

510

           collect (list zone subzone (when transition-idx (elt (timezone-transitions zone) transition-idx)))

511

else

512

when transition-idx

513

nconc (loop for subzone-idx from 0 below (length (timezone-subzones zone))

514

for sz = (elt (timezone-subzones zone) subzone-idx)

515

                         for tix = (position subzone-idx (timezone-indexes zone) :from-end t)

516

when (and tix (equal abbreviated-name (subzone-abbrev sz)))

517

                           collect (list zone sz (elt (timezone-transitions zone) tix)))))

518

519

(defun timezone= (timezone-1 timezone-2)

520

   "Return two values indicating the relationship between timezone-1 and timezone-2. The first value is whether the two timezones are equal and the second value indicates whether it is sure or not.

521

522

In other words:

523

\(values t t) means timezone-1 and timezone-2 are definitely equal.

524

\(values nil t) means timezone-1 and timezone-2 are definitely different.

525

\(values nil nil) means that it couldn't be determined."

526

(if (or (eq timezone-1 timezone-2)

527

(equalp timezone-1 timezone-2))

528

(values t t)

529

(values nil nil)))

530

531

(defun reread-timezone-repository (&key (timezone-repository *default-timezone-repository-path*))

532

(check-type timezone-repository (or pathname string))

533

(let ((root-directory (uiop:directory-exists-p timezone-repository)))

534

(unless root-directory

535

(error "REREAD-TIMEZONE-REPOSITORY was called with invalid PROJECT-DIRECTORY (~A)."

536

timezone-repository))

537

(let ((cutoff-position (length (princ-to-string root-directory))))

538

(flet ((visitor (file)

539

(handler-case

540

(let* ((full-name (subseq (princ-to-string file) cutoff-position))

541

                           (timezone (%realize-timezone (make-timezone :path file :name full-name))))

542

(setf (gethash full-name *location-name->timezone*) timezone)

543

(map nil (lambda (subzone)

544

(push timezone (gethash (subzone-abbrev subzone)

545

                                                         *abbreviated-subzone-name->timezone-list*)))

546

(timezone-subzones timezone)))

547

(invalid-timezone-file () nil))))

548

(setf *location-name->timezone*

549

(make-hash-table :test 'equal

550

#+sbcl :synchronized #+sbcl t))

551

(setf *abbreviated-subzone-name->timezone-list*

552

(make-hash-table :test 'equal

553

#+sbcl :synchronized #+sbcl t))

554

(uiop:collect-sub*directories root-directory

555

(constantly t)

556

(constantly t)

557

(lambda (dir)

558

                                         (dolist (file (uiop:directory-files dir))

559

                                           (when (not (find "Etc" (pathname-directory file)

560

                                                            :test #'string=))

561

(visitor file)))))

562

(uiop:collect-sub*directories (merge-pathnames "Etc/" root-directory)

563

(constantly t)

564

(constantly t)

565

(lambda (dir)

566

                                         (dolist (file (uiop:directory-files dir))

567

(visitor file))))))))

568

569

(defmacro make-timestamp (&rest args)

570

`(make-instance 'timestamp ,@args))

571

572

(defun clone-timestamp (timestamp)

573

(make-instance 'timestamp

574

:nsec (nsec-of timestamp)

575

:sec (sec-of timestamp)

576

:day (day-of timestamp)))

577

578

(defun sec-day-subtimezone (sec day timezone)

579

(declare (type integer sec day)

580

(type timezone timezone))

581

(let ((subzone (%subzone-as-of timezone sec day)))

582

(values (subzone-offset subzone)

583

(subzone-daylight-p subzone)

584

(subzone-abbrev subzone))))

585

586

(defun timestamp-subtimezone (timestamp timezone)

587

   "Return as multiple values the time zone as the number of seconds east of UTC, a boolean daylight-saving-p, and the customary abbreviation of the timezone."

588

(declare (type timestamp timestamp)

589

(type (or null timezone) timezone))

590

(sec-day-subtimezone (sec-of timestamp)

591

(day-of timestamp)

592

(%realize-timezone (or timezone *default-timezone*))))

593

594

(defun %adjust-to-offset (sec day offset)

595

   "Returns two values, the values of new DAY and SEC slots of the timestamp adjusted to the given timezone."

596

(declare (type integer sec day offset))

597

(multiple-value-bind (offset-day new-sec)

598

(floor (+ sec offset) +seconds-per-day+)

599

(values new-sec (+ day offset-day))))

600

601

(defun %adjust-to-timezone (source timezone &optional offset)

602

(%adjust-to-offset (sec-of source)

603

(day-of source)

604

(or offset

605

(timestamp-subtimezone source timezone))))

606

607

(defun timestamp-minimize-part (timestamp part &key

608

(timezone *default-timezone*)

609

into)

610

(let* ((timestamp-parts '(:nsec :sec :min :hour :day :month))

611

(part-count (position part timestamp-parts)))

612

(assert part-count nil

613

"timestamp-minimize-part called with invalid part ~a (expected one of ~a)"

614

part

615

timestamp-parts)

616

(multiple-value-bind (nsec sec min hour day month year)

617

(decode-timestamp timestamp :timezone timezone)

618

(declare (ignore nsec))

619

(encode-timestamp 0

620

(if (> part-count 0) 0 sec)

621

(if (> part-count 1) 0 min)

622

(if (> part-count 2) 0 hour)

623

(if (> part-count 3) 1 day)

624

(if (> part-count 4) 1 month)

625

year

626

:timezone timezone

627

:into into))))

628

629

(defun timestamp-maximize-part (timestamp part &key

630

(timezone *default-timezone*)

631

into)

632

(let* ((timestamp-parts '(:nsec :sec :min :hour :day :month))

633

(part-count (position part timestamp-parts)))

634

(assert part-count nil

635

"timestamp-maximize-part called with invalid part ~a (expected one of ~a)"

636

part

637

timestamp-parts)

638

(multiple-value-bind (nsec sec min hour day month year)

639

(decode-timestamp timestamp :timezone timezone)

640

(declare (ignore nsec))

641

(let ((month (if (> part-count 4) 12 month)))

642

(encode-timestamp 999999999

643

(if (> part-count 0) 59 sec)

644

(if (> part-count 1) 59 min)

645

(if (> part-count 2) 23 hour)

646

(if (> part-count 3) (days-in-month month year) day)

647

month

648

year

649

:timezone timezone

650

:into into)))))

651

652

 (defmacro with-decoded-timestamp ((&key nsec sec minute hour day month year day-of-week daylight-p timezone offset)

653

timestamp &body forms)

654

   "This macro binds variables to the decoded elements of TIMESTAMP. The TIMEZONE argument is used for decoding the timestamp, and is not bound by the macro. The value of DAY-OF-WEEK starts from 0 which means Sunday."

655

(let ((ignores)

656

(types)

657

(variables))

658

(macrolet ((initialize (&rest vars)

659

`(progn

660

,@(loop

661

:for var :in vars

662

:collect `(progn

663

(unless ,var

664

(setf ,var (gensym))

665

(push ,var ignores))

666

(push ,var variables)))

667

(setf ignores (nreverse ignores))

668

(setf variables (nreverse variables))))

669

(declare-fixnum-type (&rest vars)

670

`(progn

671

,@(loop

672

:for var :in vars

673

:collect `(when ,var

674

(push `(type fixnum ,,var) types)))

675

(setf types (nreverse types)))))

676

(when nsec

677

(push `(type (integer 0 999999999) ,nsec) types))

678

(declare-fixnum-type sec minute hour day month year)

679

(initialize nsec sec minute hour day month year day-of-week daylight-p))

680

`(multiple-value-bind (,@variables)

681

(decode-timestamp ,timestamp :timezone ,(or timezone '*default-timezone*) :offset ,offset)

682

(declare (ignore ,@ignores) ,@types)

683

,@forms)))

684

685

(defun %normalize-month-year-pair (month year)

686

   "Normalizes the month/year pair: in case month is < 1 or > 12 the month and year are corrected to handle the overflow."

687

(multiple-value-bind (year-offset month-minus-one)

688

(floor (1- month) 12)

689

(values (1+ month-minus-one)

690

(+ year year-offset))))

691

692

(defun days-in-month (month year)

693

"Returns the number of days in the given month of the specified year."

694

(let ((normal-days (aref +rotated-month-days-without-leap-day+

695

(mod (+ month 9) 12))))

696

(if (and (= month 2)

697

(or (and (zerop (mod year 4))

698

(plusp (mod year 100)))

699

(zerop (mod year 400))))

700

(1+ normal-days) ; February on a leap year

701

normal-days)))

702

703

 ;; TODO scan all uses of FIX-OVERFLOW-IN-DAYS and decide where it's ok to silently fix and where should be and error reported

704

(defun %fix-overflow-in-days (day month year)

705

   "In case the day number is higher than the maximal possible for the given month/year pair, returns the last day of the month."

706

(let ((max-day (days-in-month month year)))

707

(if (> day max-day)

708

max-day

709

day)))

710

711

(eval-when (:compile-toplevel :load-toplevel)

712

(defun %list-length= (num list)

713

"Tests for a list of length NUM without traversing the entire list to get the length."

714

(let ((c (nthcdr (1- num) list)))

715

(and c (endp (cdr c)))))

716

717

(defun %expand-adjust-timestamp-changes (timestamp changes visitor)

718

(loop

719

:with params = ()

720

:with functions = ()

721

:for change in changes

722

:do

723

(progn

724

(assert (or

725

(%list-length= 3 change)

726

(and (%list-length= 2 change)

727

(symbolp (first change))

728

(or (string= (first change) :timezone)

729

(string= (first change) :utc-offset)))

730

(and (%list-length= 4 change)

731

(symbolp (third change))

732

(or (string= (third change) :to)

733

(string= (third change) :by))))

734

nil "Syntax error in expression ~S" change)

735

(let ((operation (first change))

736

(part (second change))

737

(value (if (%list-length= 3 change)

738

(third change)

739

(fourth change))))

740

(cond

741

((string= operation :set)

742

(push `(%set-timestamp-part ,part ,value) functions))

743

((string= operation :offset)

744

(push `(%offset-timestamp-part ,part ,value) functions))

745

((string= operation :utc-offset)

746

(push part params)

747

(push :utc-offset params))

748

((string= operation :timezone)

749

(push part params)

750

(push :timezone params))

751

(t (error "Unexpected operation ~S" operation)))))

752

:finally

753

(loop

754

:for (function part value) in functions

755

:do

756

(funcall visitor `(,function ,timestamp ,part ,value ,@params)))))

757

758

(defun %expand-adjust-timestamp (timestamp changes &key functional)

759

(let* ((old (gensym "OLD"))

760

(new (if functional

761

(gensym "NEW")

762

old))

763

(forms (list)))

764

(%expand-adjust-timestamp-changes old changes

765

(lambda (change)

766

(push

767

`(progn

768

                                               (multiple-value-bind (nsec sec day)

769

,change

770

                                                 (setf (nsec-of ,new) nsec)

771

                                                 (setf (sec-of ,new) sec)

772

                                                 (setf (day-of ,new) day))

773

,@(when functional

774

                                                       `((setf ,old ,new))))

775

forms)))

776

(setf forms (nreverse forms))

777

`(let* ((,old ,timestamp)

778

,@(when functional

779

`((,new (clone-timestamp ,old)))))

780

,@forms

781

,old)))

782

) ; eval-when

783

784

(defmacro adjust-timestamp (timestamp &body changes)

785

(%expand-adjust-timestamp timestamp changes :functional t))

786

787

(defmacro adjust-timestamp! (timestamp &body changes)

788

(%expand-adjust-timestamp timestamp changes :functional nil))

789

790

(defun %set-timestamp-part (time part new-value &key (timezone *default-timezone*) utc-offset)

791

;; TODO think about error signalling. when, how to disable if it makes sense, ...

792

(case part

793

((:nsec :sec-of-day :day)

794

(let ((nsec (nsec-of time))

795

(sec (sec-of time))

796

(day (day-of time)))

797

(case part

798

(:nsec (setf nsec (coerce new-value '(integer 0 999999999))))

799

(:sec-of-day (setf sec (coerce new-value `(integer 0 ,+seconds-per-day+))))

800

(:day (setf day new-value)))

801

(values nsec sec day)))

802

(otherwise

803

(with-decoded-timestamp (:nsec nsec :sec sec :minute minute :hour hour

804

                               :day day :month month :year year :timezone timezone :offset utc-offset)

805

time

806

(ecase part

807

(:sec (setf sec new-value))

808

(:minute (setf minute new-value))

809

(:hour (setf hour new-value))

810

(:day-of-month (setf day new-value))

811

(:month (setf month new-value)

812

(setf day (%fix-overflow-in-days day month year)))

813

(:year (setf year new-value)

814

(setf day (%fix-overflow-in-days day month year))))

815

        (encode-timestamp-into-values nsec sec minute hour day month year :timezone timezone :offset utc-offset)))))

816

817

(defun %offset-timestamp-part (time part offset &key (timezone *default-timezone*) utc-offset)

818

"Returns a time adjusted by the specified OFFSET. Takes care of

819

different kinds of overflows. The setting :day-of-week is possible

820

using a keyword symbol name of a week-day (see

821

+DAY-NAMES-AS-KEYWORDS+) as value. In that case point the result to

822

day given by OFFSET in the week that contains TIME."

823

(labels ((direct-adjust (part offset nsec sec day)

824

(cond ((eq part :day-of-week)

825

(with-decoded-timestamp (:day-of-week day-of-week

826

                                                           :nsec nsec :sec sec :minute minute :hour hour

827

                                                           :day day :month month :year year

828

                                                           :timezone timezone :offset utc-offset)

829

time

830

                       (let ((position (position offset +day-names-as-keywords+ :test #'eq)))

831

                         (assert position (position) "~S is not a valid day name" offset)

832

(let ((offset (+ (- (if (zerop day-of-week)

833

7

834

day-of-week))

835

position)))

836

(incf day offset)

837

(cond

838

((< day 1)

839

(decf month)

840

(when (< month 1)

841

(setf month 12)

842

(decf year))

843

(setf day (+ (days-in-month month year) day)))

844

((let ((days-in-month (days-in-month month year)))

845

(when (< days-in-month day)

846

(incf month)

847

(when (= month 13)

848

(setf month 1)

849

(incf year))

850

(decf day days-in-month)))))

851

                           (encode-timestamp-into-values nsec sec minute hour day month year

852

                                                         :timezone timezone :offset utc-offset)))))

853

((zerop offset)

854

                     ;; The offset is zero, so just return the parts of the timestamp object

855

(values nsec sec day))

856

(t

857

(let ((old-utc-offset (or utc-offset

858

                                               (timestamp-subtimezone time timezone)))

859

new-utc-offset)

860

(tagbody

861

top

862

(ecase part

863

(:nsec

864

(multiple-value-bind (sec-offset new-nsec)

865

(floor (+ offset nsec) 1000000000)

866

                               ;; the time might need to be adjusted a bit more if q != 0

867

(setf part :sec

868

offset sec-offset

869

nsec new-nsec)

870

(go top)))

871

((:sec :minute :hour)

872

(multiple-value-bind (days-offset new-sec)

873

(floor (+ sec (* offset (ecase part

874

                                                           (:sec 1)

875

                                                           (:minute +seconds-per-minute+)

876

                                                           (:hour +seconds-per-hour+))))

877

+seconds-per-day+)

878

                               (return-from direct-adjust (values nsec new-sec (+ day days-offset)))))

879

(:day

880

(incf day offset)

881

(setf new-utc-offset (or utc-offset

882

                                                      (timestamp-subtimezone (make-timestamp :nsec nsec :sec sec :day day)

883

                                                                             timezone)))

884

(when (not (= old-utc-offset

885

new-utc-offset))

886

                               ;; We hit the DST boundary. We need to restart again

887

                               ;; with :sec, but this time we know both old and new

888

                               ;; UTC offset will be the same, so it's safe to do

889

(setf part :sec

890

offset (- old-utc-offset

891

new-utc-offset)

892

old-utc-offset new-utc-offset)

893

(go top))

894

(return-from direct-adjust (values nsec sec day)))))))))

895

896

(safe-adjust (part offset time)

897

(with-decoded-timestamp (:nsec nsec :sec sec :minute minute :hour hour :day day

898

                                             :month month :year year :timezone timezone :offset utc-offset)

899

time

900

(multiple-value-bind (month-new year-new)

901

(%normalize-month-year-pair

902

(+ (ecase part

903

(:month offset)

904

(:year (* 12 offset)))

905

month)

906

year)

907

;; Almost there. However, it is necessary to check for

908

;; overflows first

909

(encode-timestamp-into-values nsec sec minute hour

910

                                                (%fix-overflow-in-days day month-new year-new)

911

month-new year-new

912

                                                :timezone timezone :offset utc-offset)))))

913

(ecase part

914

((:nsec :sec :minute :hour :day :day-of-week)

915

(direct-adjust part offset

916

(nsec-of time)

917

(sec-of time)

918

(day-of time)))

919

((:month :year) (safe-adjust part offset time)))))

920

921

(defun timestamp-difference (time-a time-b)

922

"Returns the difference between TIME-A and TIME-B in seconds"

923

(let ((nsec (- (nsec-of time-a) (nsec-of time-b)))

924

(second (- (sec-of time-a) (sec-of time-b)))

925

(day (- (day-of time-a) (day-of time-b))))

926

(when (minusp nsec)

927

(decf second)

928

(incf nsec 1000000000))

929

(when (minusp second)

930

(decf day)

931

(incf second +seconds-per-day+))

932

(let ((result (+ (* day +seconds-per-day+)

933

second)))

934

(unless (zerop nsec)

935

;; this incf turns the result into a float, so only do this when necessary

936

(incf result (/ nsec 1000000000d0)))

937

result)))

938

939

(defun timestamp+ (time amount unit &optional (timezone *default-timezone*) offset)

940

(multiple-value-bind (nsec sec day)

941

(%offset-timestamp-part time unit amount :timezone timezone :utc-offset offset)

942

(make-timestamp :nsec nsec

943

:sec sec

944

:day day)))

945

946

(defun timestamp- (time amount unit &optional (timezone *default-timezone*) offset)

947

(timestamp+ time (- amount) unit timezone offset))

948

949

(defun %ts-day-of-week (ts-day)

950

(mod (+ 3 ts-day) 7))

951

952

(defun timestamp-day-of-week (timestamp &key (timezone *default-timezone*) offset)

953

(%ts-day-of-week (nth-value 1 (%adjust-to-timezone timestamp timezone offset))))

954

955

;; TODO read

956

;; http://java.sun.com/j2se/1.4.2/docs/api/java/util/GregorianCalendar.html

957

;; (or something else, sorry :) this scheme only works back until

958

;; 1582, the start of the gregorian calendar. see also

959

;; DECODE-TIMESTAMP when fixing if fixing is desired at all.

960

(defun valid-timestamp-p (nsec sec minute hour day month year)

961

"Returns T if the time values refer to a valid time, otherwise returns NIL."

962

(and (<= 0 nsec 999999999)

963

(<= 0 sec 59)

964

(<= 0 minute 59)

965

(<= 0 hour 23)

966

(<= 1 month 12)

967

(<= 1 day (days-in-month month year))

968

(/= year 0)))

969

970

(defun encode-sec-day (sec minute hour day month year)

971

(declare (type integer sec minute hour day month year))

972

(values (+ (* hour +seconds-per-hour+)

973

(* minute +seconds-per-minute+)

974

sec)

975

(multiple-value-bind (ts-month ts-year)

976

(if (< month 3)

977

(values (+ month 9) (- year 2001))

978

(values (- month 3) (- year 2000)))

979

(+ (years-to-days ts-year)

980

(aref +rotated-month-offsets-without-leap-day+ ts-month)

981

(1- day)))))

982

983

(defun encode-offset (ts-sec ts-day timezone)

984

(subzone-offset

985

(%subzone-as-of (%realize-timezone (or timezone *default-timezone*))

986

ts-sec

987

ts-day

988

t)))

989

990

(defun encode-timestamp-into-values (nsec sec minute hour day month year

991

&key timezone offset)

992

"Returns (VALUES NSEC SEC DAY ZONE) ready to be used for

993

instantiating a new timestamp object. If the specified time is

994

invalid, the condition INVALID-TIME-SPECIFICATION is raised."

995

;; If the user provided an explicit offset, we use that. Otherwise,

996

(declare (type integer nsec sec minute hour day month year)

997

(type (or integer null) offset))

998

(unless (valid-timestamp-p nsec sec minute hour day month year)

999

(error 'invalid-time-specification))

1000

(multiple-value-bind (enc-sec enc-day)

1001

(encode-sec-day sec minute hour day month year)

1002

(multiple-value-bind (ts-sec ts-day)

1003

(%adjust-to-offset enc-sec

1004

enc-day

1005

(- (or offset

1006

(encode-offset enc-sec enc-day timezone))))

1007

(values nsec ts-sec ts-day))))

1008

1009

(defun encode-timestamp (nsec sec minute hour day month year

1010

&key (timezone *default-timezone*) offset into)

1011

"Return a new TIMESTAMP instance corresponding to the specified time

1012

elements."

1013

(declare (type integer nsec sec minute hour day month year))

1014

(multiple-value-bind (nsec sec day)

1015

(encode-timestamp-into-values nsec sec minute hour day month year

1016

:timezone timezone :offset offset)

1017

(if into

1018

(progn

1019

(setf (nsec-of into) nsec)

1020

(setf (sec-of into) sec)

1021

(setf (day-of into) day)

1022

into)

1023

(make-timestamp

1024

:nsec nsec

1025

:sec sec

1026

:day day))))

1027

1028

(defun universal-sec-day (universal)

1029

(let ((adjusted-universal (- universal #.(encode-universal-time 0 0 0 1 3 2000 0))))

1030

(multiple-value-bind (ts-day ts-sec)

1031

(floor adjusted-universal +seconds-per-day+)

1032

(values ts-sec ts-day))))

1033

1034

(defun universal-to-timestamp (universal &key (nsec 0))

1035

"Returns a timestamp corresponding to the given universal time."

1036

;; universal time is seconds from 1900-01-01T00:00:00Z.

1037

(multiple-value-bind (ts-sec ts-day)

1038

(universal-sec-day universal)

1039

(make-timestamp :day ts-day :sec ts-sec :nsec nsec)))

1040

1041

(defun ts-sec-day-to-universal (ts-sec ts-day)

1042

"Return the UNIVERSAL-TIME corresponding to the TIMESTAMP"

1043

;; universal time is seconds from 1900-01-01T00:00:00Z

1044

(+ (* ts-day +seconds-per-day+)

1045

ts-sec

1046

#.(encode-universal-time 0 0 0 1 3 2000 0)))

1047

1048

(defun timestamp-to-universal (timestamp)

1049

"Return the UNIVERSAL-TIME corresponding to the TIMESTAMP"

1050

;; universal time is seconds from 1900-01-01T00:00:00Z

1051

(ts-sec-day-to-universal (sec-of timestamp) (day-of timestamp)))

1052

1053

(defun unix-to-timestamp (unix &key (nsec 0))

1054

"Return a TIMESTAMP corresponding to UNIX, which is the number of seconds since

1055

the unix epoch, 1970-01-01T00:00:00Z."

1056

(multiple-value-bind (days secs)

1057

(floor unix +seconds-per-day+)

1058

(make-timestamp :day (- days 11017) :sec secs :nsec nsec)))

1059

1060

(defun timestamp-values-to-unix (seconds day)

1061

"Return the Unix time corresponding to the values used to encode a TIMESTAMP"

1062

(+ (* (+ day 11017) +seconds-per-day+) seconds))

1063

1064

(defun timestamp-to-unix (timestamp)

1065

"Return the Unix time corresponding to the TIMESTAMP"

1066

(declare (type timestamp timestamp))

1067

(timestamp-values-to-unix (sec-of timestamp) (day-of timestamp)))

1068

1069

(defun timestamp-to-octets (timestamp)

1070

"Return an octet-vector consisting of 2-byte day, 2-byte sec, and 4-byte nsec."

1071

(concatenate 'octet-vector

1072

(integer-to-octets (day-of timestamp) 16)

1073

(integer-to-octets (sec-of timestamp) 16)

1074

(integer-to-octets (nsec-of timestamp) 32)))

1075

1076

(defun octets-to-timestamp (buf)

1077

"Return a timestamp from an 8-byte octet-vector."

1078

(make-timestamp

1079

:day (octets-to-integer (subseq buf 0 2))

1080

:sec (octets-to-integer (subseq buf 2 4))

1081

:nsec (octets-to-integer (subseq buf 4 8))))

1082

1083

(defun %get-current-time ()

1084

   "Cross-implementation abstraction to get the current time measured from the unix epoch (1/1/1970). Should return (values sec nano-sec)."

1085

(progn

1086

#+#.(obj/time::package-with-symbol? "SB-EXT" "GET-TIME-OF-DAY") ; available from sbcl 1.0.28.66

1087

(multiple-value-bind (sec nsec) (sb-ext:get-time-of-day)

1088

(values sec (* 1000 nsec)))

1089

     #-#.(obj/time::package-with-symbol? "SB-EXT" "GET-TIME-OF-DAY") ; obsolete, scheduled to be deleted at the end of 2009

1090

(multiple-value-bind (success? sec nsec) (sb-unix:unix-gettimeofday)

1091

(assert success? () "sb-unix:unix-gettimeofday reported failure?!")

1092

(values sec (* 1000 nsec)))))

1093

1094

(defvar *clock* t

1095

"Use the `*clock*' special variable if you need to define your own idea of the current time.

1096

1097

 The value of this variable should have at least a method `obj/time::clock-now'; there may also be a `obj/time::clock-today' method, although the default based on `obj/time::clock-now' will probably do the job.

1098

The currently supported values in obj/time are:

1099

t - use the standard clock

1100

   obj/time:leap-second-adjusted - use a clock which adjusts for leap seconds using the information in *default-timezone*.")

1101

1102

(defun now ()

1103

"Returns a timestamp representing the present moment."

1104

(clock-now *clock*))

1105

1106

(defun today ()

1107

"Returns a timestamp representing the present day (assuming UTC)."

1108

(clock-today *clock*))

1109

1110

(defun format-date-simple (&optional dest timestamp)

1111

"Return a simple date string for today."

1112

(unless timestamp (setq timestamp (today)))

1113

(format-timestring dest timestamp

1114

:format '(:year #\- (:month 2) #\- (:day 2))))

1115

1116

(defgeneric clock-now (clock)

1117

(:documentation "Returns a timestamp for the current time given a clock."))

1118

1119

(defgeneric clock-today (clock)

1120

(:documentation "Returns a timestamp for the current date given a

1121

clock. The date is encoded by convention as a timestamp with the time set to

1122

00:00:00UTC."))

1123

1124

(defgeneric date (self)

1125

(:documentation "Return the date of object SELF."))

1126

1127

(defgeneric duration (self)

1128

(:documentation "Return the duration of object SELF."))1

1129

1130

(defun %leap-seconds-offset (leap-seconds sec)

1131

"Find the latest leap second adjustment effective at SEC system time."

1132

(elt (leap-seconds-adjustment leap-seconds)

1133

(transition-position sec (leap-seconds-sec leap-seconds))))

1134

1135

(defun %adjust-sec-for-leap-seconds (sec)

1136

   "Ajdust SEC from system time to Unix time (on systems those clock does not jump back over leap seconds)."

1137

(let ((leap-seconds (timezone-leap-seconds (%realize-timezone *default-timezone*))))

1138

(when leap-seconds

1139

(decf sec (%leap-seconds-offset leap-seconds sec))))

1140

sec)

1141

1142

(defmethod clock-now ((clock (eql 'leap-second-adjusted)))

1143

(multiple-value-bind (sec nsec) (%get-current-time)

1144

(unix-to-timestamp (%adjust-sec-for-leap-seconds sec)

1145

:nsec nsec)))

1146

1147

(defmethod clock-now (clock)

1148

(declare (ignore clock))

1149

(multiple-value-bind (sec nsec) (%get-current-time)

1150

(unix-to-timestamp sec :nsec nsec)))

1151

1152

(defmethod clock-today (clock)

1153

;; TODO should return a date value, anyhow we will decide to represent it eventually

1154

(let ((result (clock-now clock)))

1155

(setf (sec-of result) 0)

1156

(setf (nsec-of result) 0)

1157

result))

1158

1159

(defmacro %defcomparator (name &body body)

1160

(let ((pair-comparator-name (intern (concatenate 'string "%" (string name)))))

1161

`(progn

1162

(declaim (inline ,pair-comparator-name))

1163

(defun ,pair-comparator-name (time-a time-b)

1164

(assert (typep time-a 'timestamp)

1165

nil

1166

'type-error

1167

:datum time-a

1168

:expected-type 'timestamp)

1169

(assert (typep time-b 'timestamp)

1170

nil

1171

'type-error

1172

:datum time-b

1173

:expected-type 'timestamp)

1174

,@body)

1175

(defun ,name (&rest times)

1176

(declare (dynamic-extent times))

1177

(loop for head on times

1178

while (cdr head)

1179

always (,pair-comparator-name (first head) (second head))))

1180

(define-compiler-macro ,name (&rest times)

1181

(let ((vars (loop

1182

:for i :upfrom 0 :below (length times)

1183

                       :collect (gensym (concatenate 'string "TIME-" (princ-to-string i) "-")))))

1184

`(let (,@(loop

1185

:for var :in vars

1186

:for time :in times

1187

:collect (list var time)))

1188

;; we could evaluate comparisons of timestamp literals here

1189

(and ,@(loop

1190

:for (time-a time-b) :on vars

1191

:while time-b

1192

:collect `(,',pair-comparator-name ,time-a ,time-b)))))))))

1193

1194

(defun %timestamp-compare (time-a time-b)

1195

"Returns the symbols <, >, or =, describing the relationship between TIME-A and TIME-b."

1196

(declare (type timestamp time-a time-b))

1197

(cond

1198

((< (day-of time-a) (day-of time-b)) '<)

1199

((> (day-of time-a) (day-of time-b)) '>)

1200

((< (sec-of time-a) (sec-of time-b)) '<)

1201

((> (sec-of time-a) (sec-of time-b)) '>)

1202

((< (nsec-of time-a) (nsec-of time-b)) '<)

1203

((> (nsec-of time-a) (nsec-of time-b)) '>)

1204

(t '=)))

1205

1206

(%defcomparator timestamp<

1207

(eql (%timestamp-compare time-a time-b) '<))

1208

1209

(%defcomparator timestamp<=

1210

(not (null (member (%timestamp-compare time-a time-b) '(< =)))))

1211

1212

(%defcomparator timestamp>

1213

(eql (%timestamp-compare time-a time-b) '>))

1214

1215

(%defcomparator timestamp>=

1216

(not (null (member (%timestamp-compare time-a time-b) '(> =)))))

1217

1218

(%defcomparator timestamp=

1219

(eql (%timestamp-compare time-a time-b) '=))

1220

1221

(defun timestamp/= (&rest timestamps)

1222

"Returns T if no pair of timestamps is equal. Otherwise return NIL."

1223

(declare (dynamic-extent timestamps))

1224

(loop for ts-head on timestamps do

1225

(loop for ts in (rest ts-head) do

1226

(when (timestamp= (car ts-head) ts)

1227

(return-from timestamp/= nil))))

1228

t)

1229

1230

(defun contest (test list)

1231

"Applies TEST to pairs of elements in list, keeping the element which last

1232

tested T. Returns the winning element."

1233

(reduce (lambda (a b) (if (funcall test a b) a b)) list))

1234

1235

(defun timestamp-minimum (time &rest times)

1236

"Returns the earliest timestamp"

1237

(contest #'timestamp< (cons time times)))

1238

1239

(defun timestamp-maximum (time &rest times)

1240

"Returns the latest timestamp"

1241

(contest #'timestamp> (cons time times)))

1242

1243

(eval-when (:compile-toplevel :load-toplevel :execute)

1244

(defun years-to-days (years)

1245

"Given a number of years, returns the number of days in those years."

1246

(let* ((days (* years 365))

1247

(l1 (floor years 4))

1248

(l2 (floor years 100))

1249

(l3 (floor years 400)))

1250

(+ days l1 (- l2) l3))))

1251

1252

(defun days-to-years (days)

1253

"Given a number of days, returns the number of years and the remaining days in that year."

1254

(let ((remaining-days days))

1255

(multiple-value-bind (400-years remaining-days)

1256

(floor remaining-days #.(years-to-days 400))

1257

(let* ((100-years (min (floor remaining-days #.(years-to-days 100)) 3))

1258

(remaining-days (- remaining-days

1259

(* 100-years #.(years-to-days 100)))))

1260

(multiple-value-bind (4-years remaining-days)

1261

(floor remaining-days #.(years-to-days 4))

1262

(let ((years (min 3 (floor remaining-days #.(years-to-days 1)))))

1263

(values (+ (* 400-years 400)

1264

(* 100-years 100)

1265

(* 4-years 4)

1266

years)

1267

(- remaining-days (* years 365))))))))

1268

   ;; the above is the macroexpansion of the following. uses metabang BIND, but kept for clarity because the expansion is unreadable.

1269

#+nil

1270

(bind ((remaining-days days)

1271

((values 400-years remaining-days) (floor remaining-days #.(years-to-days 400)))

1272

(100-years (min (floor remaining-days #.(years-to-days 100))

1273

3))

1274

(remaining-days (- remaining-days

1275

(* 100-years

1276

#.(years-to-days 100))))

1277

((values 4-years remaining-days) (floor remaining-days #.(years-to-days 4)))

1278

(years (min (floor remaining-days 365)

1279

3)))

1280

(values (+ (* 400-years 400)

1281

(* 100-years 100)

1282

(* 4-years 4)

1283

years)

1284

(- remaining-days (* years 365)))))

1285

1286

;; TODO merge this functionality into timestamp-difference

1287

(defun timestamp-whole-year-difference (time-a time-b)

1288

"Returns the number of whole years elapsed between time-a and time-b (hint: anniversaries)."

1289

(declare (type timestamp time-b time-a))

1290

   (multiple-value-bind (nsec-b sec-b minute-b hour-b day-b month-b year-b day-of-week-b daylight-p-b offset-b)

1291

(decode-timestamp time-b)

1292

(declare (ignore day-of-week-b daylight-p-b))

1293

(multiple-value-bind (nsec-a sec-a minute-a hour-a day-a month-a year-a)

1294

(decode-timestamp time-a)

1295

(declare (ignore nsec-a sec-a minute-a hour-a day-a month-a))

1296

(let ((year-difference (- year-a year-b)))

1297

(if (timestamp<= (encode-timestamp nsec-b sec-b minute-b hour-b

1298

(if (= month-b 2)

1299

(min 28 day-b)

1300

day-b)

1301

month-b

1302

(+ year-difference year-b)

1303

:offset offset-b)

1304

time-a)

1305

year-difference

1306

(1- year-difference))))))

1307

1308

(defun %timestamp-decode-date (days)

1309

"Returns the year, month, and day, given the number of days from the epoch."

1310

(declare (type integer days))

1311

(multiple-value-bind (years remaining-days)

1312

(days-to-years days)

1313

(let* ((leap-day-p (= remaining-days 365))

1314

(rotated-1-based-month (if leap-day-p

1315

                                       12 ; march is the first month and february is the last

1316

                                       (position remaining-days +rotated-month-offsets-without-leap-day+ :test #'<)))

1317

(1-based-month (if (>= rotated-1-based-month 11)

1318

(- rotated-1-based-month 10)

1319

(+ rotated-1-based-month 2)))

1320

(1-based-day (if leap-day-p

1321

29

1322

                             (1+ (- remaining-days (aref +rotated-month-offsets-without-leap-day+

1323

                                                         (1- rotated-1-based-month)))))))

1324

(values

1325

(+ years

1326

(if (>= rotated-1-based-month 11) ; january is in the next year

1327

2001

1328

2000))

1329

1-based-month

1330

1-based-day))))

1331

1332

(defun %timestamp-decode-iso-week (timestamp)

1333

"Returns the year, week number, and day of week components of an ISO week date."

1334

;; Algorithm from http://en.wikipedia.org/wiki/Talk:ISO_week_date#Algorithms

1335

(let* ((dn (timestamp-day-of-week timestamp))

1336

(day-of-week (if (zerop dn) 7 dn)) ; ISO weekdays are Monday=1 and Sunday=7

1337

(nearest-thursday (timestamp+ timestamp (- 4 day-of-week) :day))

1338

(year (timestamp-year nearest-thursday))

1339

(month (timestamp-month nearest-thursday))

1340

(day (timestamp-day nearest-thursday))

1341

(ordinal-day (- (day-of (encode-timestamp 0 0 0 0 day month year :timezone +utc-zone+))

1342

                          (day-of (encode-timestamp 0 0 0 0 1 1 year :timezone +utc-zone+)))))

1343

(values year

1344

(1+ (floor ordinal-day 7))

1345

day-of-week)))

1346

1347

(defun %timestamp-decode-time (seconds)

1348

"Returns the hours, minutes, and seconds, given the number of seconds since midnight."

1349

(declare (type integer seconds))

1350

(multiple-value-bind (hours hour-remainder)

1351

(floor seconds +seconds-per-hour+)

1352

(multiple-value-bind (minutes seconds)

1353

(floor hour-remainder +seconds-per-minute+)

1354

(values

1355

hours

1356

minutes

1357

seconds))))

1358

1359

(defun decode-sec-day (ts-sec ts-day)

1360

(multiple-value-bind (hour minute sec)

1361

(%timestamp-decode-time ts-sec)

1362

(multiple-value-bind (year month day)

1363

(%timestamp-decode-date ts-day)

1364

(values sec minute hour

1365

day month year

1366

(%ts-day-of-week ts-day)))))

1367

1368

(defun decode-timestamp (timestamp &key (timezone *default-timezone*) offset)

1369

"Returns the decoded time as multiple values: nsec, ss, mm, hh, day, month, year, day-of-week"

1370

(declare (type timestamp timestamp))

1371

(let ((timezone (if offset (the timezone +none-zone+) timezone)))

1372

(multiple-value-bind (offset* daylight-p abbreviation)

1373

(timestamp-subtimezone timestamp timezone)

1374

(multiple-value-bind (sec minute hour day month year day-of-week)

1375

(multiple-value-call #'decode-sec-day

1376

(%adjust-to-offset (sec-of timestamp) (day-of timestamp) (or offset offset*)))

1377

(values (nsec-of timestamp)

1378

sec minute hour

1379

day month year

1380

day-of-week

1381

daylight-p

1382

(or offset offset*)

1383

abbreviation)))))

1384

1385

(defun timestamp-year (timestamp &key (timezone *default-timezone*))

1386

"Returns the cardinal year upon which the timestamp falls."

1387

(nth-value 0

1388

(%timestamp-decode-date

1389

(nth-value 1 (%adjust-to-timezone timestamp timezone)))))

1390

1391

(defun timestamp-century (timestamp &key (timezone *default-timezone*))

1392

"Returns the ordinal century upon which the timestamp falls."

1393

(let* ((year (timestamp-year timestamp :timezone timezone))

1394

(sign (signum year)))

1395

(+ sign

1396

(* sign

1397

(truncate (1- (abs year)) 100)))))

1398

1399

(defun timestamp-millennium (timestamp &key (timezone *default-timezone*))

1400

"Returns the ordinal millennium upon which the timestamp falls."

1401

(let* ((year (timestamp-year timestamp :timezone timezone))

1402

(sign (signum year)))

1403

(+ sign

1404

(* sign

1405

(truncate (1- (abs year)) 1000)))))

1406

1407

(defun timestamp-decade (timestamp &key (timezone *default-timezone*))

1408

"Returns the cardinal decade upon which the timestamp falls."

1409

(truncate (timestamp-year timestamp :timezone timezone) 10))

1410

1411

(defun timestamp-month (timestamp &key (timezone *default-timezone*))

1412

"Returns the month upon which the timestamp falls."

1413

(nth-value 1

1414

(%timestamp-decode-date

1415

(nth-value 1 (%adjust-to-timezone timestamp timezone)))))

1416

1417

(defun timestamp-day (timestamp &key (timezone *default-timezone*))

1418

"Returns the day of the month upon which the timestamp falls."

1419

(nth-value 2

1420

(%timestamp-decode-date

1421

(nth-value 1 (%adjust-to-timezone timestamp timezone)))))

1422

1423

(defun timestamp-hour (timestamp &key (timezone *default-timezone*))

1424

(nth-value 0

1425

(%timestamp-decode-time

1426

(nth-value 0 (%adjust-to-timezone timestamp timezone)))))

1427

1428

(defun timestamp-minute (timestamp &key (timezone *default-timezone*))

1429

(nth-value 1

1430

(%timestamp-decode-time

1431

(nth-value 0 (%adjust-to-timezone timestamp timezone)))))

1432

1433

(defun timestamp-second (timestamp &key (timezone *default-timezone*))

1434

(nth-value 2

1435

(%timestamp-decode-time

1436

(nth-value 0 (%adjust-to-timezone timestamp timezone)))))

1437

1438

(defun timestamp-microsecond (timestamp)

1439

(floor (nsec-of timestamp) 1000))

1440

1441

(defun timestamp-millisecond (timestamp)

1442

(floor (nsec-of timestamp) 1000000))

1443

1444

(defun split-timestring (str &rest args)

1445

(declare (inline))

1446

(apply #'%split-timestring (coerce str 'simple-string) args))

1447

1448

(defun %split-timestring (time-string &key

1449

(start 0)

1450

(end (length time-string))

1451

(fail-on-error t) (time-separator #\:)

1452

(date-separator #\-)

1453

(date-time-separator #\T)

1454

(fract-time-separators '(#\. #\,))

1455

(allow-missing-elements t)

1456

(allow-missing-date-part allow-missing-elements)

1457

(allow-missing-time-part allow-missing-elements)

1458

(allow-missing-timezone-part allow-missing-time-part))

1459

   "Based on http://www.ietf.org/rfc/rfc3339.txt including the function names used. Returns (values year month day hour minute second nsec offset-hour offset-minute). On parsing failure, signals INVALID-TIMESTRING if FAIL-ON-ERROR is NIL, otherwise returns NIL."

1460

(declare (type character date-time-separator time-separator date-separator)

1461

(type simple-string time-string)

1462

(optimize (speed 3)))

1463

(the list

1464

(let (year month day hour minute second nsec offset-hour offset-minute)

1465

       (declare (type (or null fixnum) start end year month day hour minute second offset-hour offset-minute)

1466

(type (or null (signed-byte 32)) nsec))

1467

(macrolet ((passert (expression)

1468

`(unless ,expression

1469

(parse-error ',expression)))

1470

(parse-integer-into (start-end place &optional low-limit high-limit)

1471

(let ((entry (gensym "ENTRY"))

1472

(value (gensym "VALUE"))

1473

(pos (gensym "POS"))

1474

(start (gensym "START"))

1475

(end (gensym "END")))

1476

`(let ((,entry ,start-end))

1477

(if ,entry

1478

(let ((,start (car ,entry))

1479

(,end (cdr ,entry)))

1480

                              (multiple-value-bind (,value ,pos) (parse-integer time-string :start ,start :end ,end :junk-allowed t)

1481

(passert (= ,pos ,end))

1482

(setf ,place ,value)

1483

,(if (and low-limit high-limit)

1484

                                     `(passert (<= ,low-limit ,place ,high-limit))

1485

(values))

1486

(values)))

1487

(progn

1488

(passert allow-missing-elements)

1489

(values))))))

1490

(with-parts-and-count ((start end split-chars) &body body)

1491

`(multiple-value-bind (parts count) (split ,start ,end ,split-chars)

1492

(declare (ignorable count) (type fixnum count)

1493

;;(type #1=(cons (cons fixnum fixnum) (or null #1#)) parts)

1494

(type list parts))

1495

,@body)))

1496

(labels ((split (start end chars)

1497

(declare (type fixnum start end))

1498

(unless (consp chars)

1499

(setf chars (list chars)))

1500

(loop with last-match = start

1501

                          with match-count of-type (integer 0 #.most-positive-fixnum) = 0

1502

for index of-type fixnum upfrom start

1503

while (< index end)

1504

                          when (member (aref time-string index) chars :test #'char-equal)

1505

collect (prog1 (if (< last-match index)

1506

(cons last-match index)

1507

nil)

1508

(incf match-count)

1509

(setf last-match (1+ index)))

1510

into result

1511

finally (return (values (if (zerop (- index last-match))

1512

result

1513

(prog1

1514

                                                          (nconc result (list (cons last-match index)))

1515

                                                        (incf match-count)))

1516

match-count))))

1517

(parse ()

1518

(with-parts-and-count (start end date-time-separator)

1519

(cond ((= count 2)

1520

(if (first parts)

1521

(full-date (first parts))

1522

(passert allow-missing-date-part))

1523

(if (second parts)

1524

(full-time (second parts))

1525

(passert allow-missing-time-part))

1526

(done))

1527

((and (= count 1)

1528

allow-missing-date-part

1529

(find time-separator time-string

1530

:start (car (first parts))

1531

:end (cdr (first parts))))

1532

(full-time (first parts))

1533

(done))

1534

((and (= count 1)

1535

allow-missing-time-part

1536

(find date-separator time-string

1537

:start (car (first parts))

1538

:end (cdr (first parts))))

1539

(full-date (first parts))

1540

(done)))

1541

(parse-error nil)))

1542

(full-date (start-end)

1543

(let ((parts (split (car start-end) (cdr start-end) date-separator)))

1544

(passert (%list-length= 3 parts))

1545

(date-fullyear (first parts))

1546

(date-month (second parts))

1547

(date-mday (third parts))))

1548

(date-fullyear (start-end)

1549

(parse-integer-into start-end year))

1550

(date-month (start-end)

1551

(parse-integer-into start-end month 1 12))

1552

(date-mday (start-end)

1553

(parse-integer-into start-end day 1 31))

1554

(full-time (start-end)

1555

(let ((start (car start-end))

1556

(end (cdr start-end)))

1557

(with-parts-and-count (start end (list #\Z #\- #\+))

1558

                        (let* ((zulup (find #\Z time-string :test #'char-equal :start start :end end))

1559

(sign (unless zulup

1560

                                       (if (find #\+ time-string :test #'char-equal :start start :end end)

1561

1

1562

-1))))

1563

(passert (<= 1 count 2))

1564

(unless (and (eq (first parts) nil)

1565

(not (rest parts)))

1566

;; not a single #\Z

1567

(partial-time (first parts)))

1568

(when zulup

1569

(setf offset-hour 0

1570

offset-minute 0))

1571

(if (= count 1)

1572

(passert (or zulup allow-missing-timezone-part))

1573

(let* ((entry (second parts))

1574

(start (car entry))

1575

(end (cdr entry)))

1576

(declare (type fixnum start end))

1577

(passert (or zulup

1578

                                             (not (zerop (- end start)))))

1579

(unless zulup

1580

(time-offset (second parts) sign))))))))

1581

(partial-time (start-end)

1582

(with-parts-and-count ((car start-end) (cdr start-end) time-separator)

1583

(passert (eql count 3))

1584

(time-hour (first parts))

1585

(time-minute (second parts))

1586

(time-second (third parts))))

1587

(time-hour (start-end)

1588

(parse-integer-into start-end hour 0 23))

1589

(time-minute (start-end)

1590

(parse-integer-into start-end minute 0 59))

1591

(time-second (start-end)

1592

                    (with-parts-and-count ((car start-end) (cdr start-end) fract-time-separators)

1593

(passert (<= 1 count 2))

1594

(let ((*read-eval* nil))

1595

(parse-integer-into (first parts) second 0 59)

1596

(if (> count 1)

1597

(let* ((start (car (second parts)))

1598

(end (cdr (second parts))))

1599

                              (declare (type (integer 0 #.array-dimension-limit) start end))

1600

(passert (<= (- end start) 9))

1601

(let ((new-end (position #\0 time-string

1602

                                                       :test-not #'eql

1603

                                                       :start start

1604

:end end

1605

                                                       :from-end t)))

1606

(when new-end

1607

(setf end (min (1+ new-end)))))

1608

                              (setf nsec (* (the (integer 0 999999999) (parse-integer time-string :start start :end end))

1609

                                            (aref #.(coerce #(1000000000 100000000 10000000

1610

                                                              1000000 100000 10000 1000 100 10 1)

1611

                                                            '(simple-array (signed-byte 32) (10)))

1612

(- end start)))))

1613

(setf nsec 0)))))

1614

(time-offset (start-end sign)

1615

(with-parts-and-count ((car start-end) (cdr start-end) time-separator)

1616

(passert (or (and allow-missing-timezone-part (zerop count))

1617

(= count 1)

1618

(= count 2)))

1619

1620

(cond

1621

((= count 2)

1622

;; hh:mm offset

1623

(parse-integer-into (first parts) offset-hour 0 23)

1624

(parse-integer-into (second parts) offset-minute 0 59))

1625

((= (- (cdar parts) (caar parts)) 4)

1626

;; hhmm offset

1627

(parse-integer-into (cons (caar parts)

1628

                                                   (+ (caar parts) 2))

1629

offset-hour 0 23)

1630

(parse-integer-into (cons (+ (caar parts) 2)

1631

                                                   (+ (caar parts) 4))

1632

offset-minute 0 59))

1633

((= (- (cdar parts) (caar parts)) 2)

1634

;; hh offset

1635

(parse-integer-into (cons (caar parts)

1636

                                                   (+ (caar parts) 2))

1637

offset-hour 0 23)

1638

(setf offset-minute 0)))

1639

1640

(setf offset-hour (* offset-hour sign)

1641

offset-minute (* offset-minute sign))))

1642

(parse-error (failure)

1643

(if fail-on-error

1644

                        (error 'invalid-timestring :timestring time-string :failure failure)

1645

(return-from %split-timestring nil)))

1646

(done ()

1647

                    (return-from %split-timestring (list year month day hour minute second nsec offset-hour offset-minute))))

1648

(parse))))))

1649

1650

(defun parse-rfc3339-timestring (timestring &key (fail-on-error t)

1651

                                             (allow-missing-time-part nil))

1652

(parse-timestring timestring :fail-on-error fail-on-error

1653

:allow-missing-timezone-part nil

1654

:allow-missing-time-part allow-missing-time-part

1655

:allow-missing-date-part nil

1656

:fract-time-separators #\.))

1657

1658

(defun parse-timestring (timestring &key

1659

start

1660

end

1661

(fail-on-error t)

1662

(time-separator #\:)

1663

(date-separator #\-)

1664

(date-time-separator #\T)

1665

(fract-time-separators '(#\. #\,))

1666

(allow-missing-elements t)

1667

(allow-missing-date-part allow-missing-elements)

1668

(allow-missing-time-part allow-missing-elements)

1669

(allow-missing-timezone-part allow-missing-elements)

1670

(offset 0))

1671

"Parse a timestring and return the corresponding TIMESTAMP.

1672

See split-timestring for details. Unspecified fields in the

1673

timestring are initialized to their lowest possible value,

1674

and timezone offset is 0 (UTC) unless explicitly specified

1675

in the input string."

1676

(let ((parts (%split-timestring (coerce timestring 'simple-string)

1677

:start (or start 0)

1678

:end (or end (length timestring))

1679

:fail-on-error fail-on-error

1680

:time-separator time-separator

1681

:date-separator date-separator

1682

:date-time-separator date-time-separator

1683

:fract-time-separators fract-time-separators

1684

:allow-missing-elements allow-missing-elements

1685

:allow-missing-date-part allow-missing-date-part

1686

:allow-missing-time-part allow-missing-time-part

1687

                                   :allow-missing-timezone-part allow-missing-timezone-part)))

1688

(when parts

1689

(destructuring-bind (year month day hour minute second nsec offset-hour offset-minute)

1690

parts

1691

(encode-timestamp

1692

(or nsec 0)

1693

(or second 0)

1694

(or minute 0)

1695

(or hour 0)

1696

(or day 1)

1697

(or month 3)

1698

(or year 2000)

1699

:offset (if offset-hour

1700

(+ (* offset-hour 3600)

1701

(* (or offset-minute 0) 60))

1702

offset))))))

1703

1704

(defun ordinalize (day)

1705

"Return an ordinal string representing the position

1706

of DAY in a sequence (1st, 2nd, 3rd, 4th, etc)."

1707

(declare (type (integer 1 31) day))

1708

(format nil "~d~a" day

1709

(if (<= 11 day 13)

1710

"th"

1711

(case (mod day 10)

1712

(1 "st")

1713

(2 "nd")

1714

(3 "rd")

1715

(t "th")))))

1716

1717

(defun %construct-timestring (timestamp format timezone)

1718

"Constructs a string representing TIMESTAMP given the FORMAT

1719

of the string and the TIMEZONE.

1720

See the documentation of FORMAT-TIMESTRING for the structure of FORMAT."

1721

(declare (type timestamp timestamp)

1722

(optimize (speed 3)))

1723

(multiple-value-bind (nsec sec minute hour day month year weekday daylight-p offset abbrev)

1724

(decode-timestamp timestamp :timezone timezone)

1725

(declare (ignore daylight-p))

1726

(multiple-value-bind (iso-year iso-week iso-weekday)

1727

(%timestamp-decode-iso-week timestamp)

1728

(let ((*print-pretty* nil)

1729

(*print-circle* nil))

1730

(with-output-to-string (result nil)

1731

(dolist (fmt format)

1732

(cond

1733

((member fmt '(:gmt-offset :gmt-offset-or-z :gmt-offset-hhmm))

1734

(multiple-value-bind (offset-hours offset-secs)

1735

(truncate offset +seconds-per-hour+)

1736

(declare (fixnum offset-hours offset-secs))

1737

(if (and (eql fmt :gmt-offset-or-z) (zerop offset))

1738

(princ #\Z result)

1739

(format result "~c~2,'0d~:[:~;~]~2,'0d"

1740

(if (minusp offset) #\- #\+)

1741

(abs offset-hours)

1742

(eql fmt :gmt-offset-hhmm)

1743

(round (abs offset-secs)

1744

+seconds-per-minute+)))))

1745

((eql fmt :short-year)

1746

(princ (mod year 100) result))

1747

((eql fmt :long-month)

1748

(princ (aref +month-names+ month) result))

1749

((eql fmt :short-month)

1750

(princ (aref +short-month-names+ month) result))

1751

((eql fmt :long-weekday)

1752

(princ (aref +day-names+ weekday) result))

1753

((eql fmt :short-weekday)

1754

(princ (aref +short-day-names+ weekday) result))

1755

((eql fmt :minimal-weekday)

1756

(princ (aref +minimal-day-names+ weekday) result))

1757

((eql fmt :timezone)

1758

(princ abbrev result))

1759

((eql fmt :ampm)

1760

(princ (if (< hour 12) "am" "pm") result))

1761

((eql fmt :ordinal-day)

1762

(princ (ordinalize day) result))

1763

((or (stringp fmt) (characterp fmt))

1764

(princ fmt result))

1765

(t

1766

(let ((val (ecase (if (consp fmt) (car fmt) fmt)

1767

(:nsec nsec)

1768

(:usec (floor nsec 1000))

1769

(:msec (floor nsec 1000000))

1770

(:sec sec)

1771

(:min minute)

1772

(:hour hour)

1773

(:hour12 (1+ (mod (1- hour) 12)))

1774

(:day day)

1775

(:weekday weekday)

1776

(:month month)

1777

(:year year)

1778

(:iso-week-year iso-year)

1779

(:iso-week-number iso-week)

1780

(:iso-week-day iso-weekday))))

1781

(cond

1782

((atom fmt)

1783

(princ val result))

1784

((minusp val)

1785

(format result "-~v,vd"

1786

(second fmt)

1787

(or (third fmt) #\0)

1788

(abs val)))

1789

(t

1790

(format result "~v,vd"

1791

(second fmt)

1792

(or (third fmt) #\0)

1793

val))))))))))))

1794

1795

(defun format-timestring (destination timestamp &key

1796

(format +iso-8601-format+)

1797

(timezone *default-timezone*))

1798

"Constructs a string representation of TIMESTAMP according

1799

to FORMAT and returns it.

1800

If destination is T, the string is written to *standard-output*.

1801

If destination is a stream, the string is written to the stream.

1802

1803

FORMAT is a list containing one or more of strings, characters,

1804

and keywords. Strings and characters are output literally,

1805

while keywords are replaced by the values here:

1806

1807

:YEAR *year

1808

:MONTH *numeric month

1809

:DAY *day of month

1810

:HOUR *hour

1811

:MIN *minutes

1812

:SEC *seconds

1813

:WEEKDAY *numeric day of week starting from index 0, which means Sunday

1814

:MSEC *milliseconds

1815

:USEC *microseconds

1816

:NSEC *nanoseconds

1817

:ISO-WEEK-YEAR *year for ISO week date (can be different from regular calendar year)

1818

:ISO-WEEK-NUMBER *ISO week number (i.e. 1 through 53)

1819

:ISO-WEEK-DAY *ISO compatible weekday number (monday=1, sunday=7)

1820

:LONG-WEEKDAY long form of weekday (e.g. Sunday, Monday)

1821

:SHORT-WEEKDAY short form of weekday (e.g. Sun, Mon)

1822

:MINIMAL-WEEKDAY minimal form of weekday (e.g. Su, Mo)

1823

:SHORT-YEAR short form of year (last 2 digits, e.g. 41, 42 instead of 2041, 2042)

1824

:LONG-MONTH long form of month (e.g. January, February)

1825

:SHORT-MONTH short form of month (e.g. Jan, Feb)

1826

:HOUR12 *hour on a 12-hour clock

1827

:AMPM am/pm marker in lowercase

1828

:GMT-OFFSET the gmt-offset of the time, in +00:00 form

1829

:GMT-OFFSET-OR-Z like :GMT-OFFSET, but is Z when UTC

1830

:GMT-OFFSET-HHMM like :GMT-OFFSET, but in +0000 form

1831

:TIMEZONE timezone abbrevation for the time

1832

1833

Elements marked by * can be placed in a list in the form

1834

\(:keyword padding &optional \(padchar #\\0))

1835

1836

The string representation of the value will be padded with the padchar.

1837

1838

You can see examples in +ISO-8601-FORMAT+, +ASCTIME-FORMAT+, and +RFC-1123-FORMAT+."

1839

(declare (type (or boolean stream) destination))

1840

(let ((result (%construct-timestring timestamp format timezone)))

1841

(when destination

1842

(write-string result (if (eq t destination) *standard-output* destination)))

1843

result))

1844

1845

(defun format-rfc1123-timestring (destination timestamp &key

1846

(timezone *default-timezone*))

1847

(format-timestring destination timestamp

1848

:format +rfc-1123-format+

1849

:timezone timezone))

1850

1851

(defun to-rfc1123-timestring (timestamp)

1852

(format-rfc1123-timestring nil timestamp))

1853

1854

(defun format-rfc3339-timestring (destination timestamp &key

1855

omit-date-part

1856

omit-time-part

1857

(omit-timezone-part omit-time-part)

1858

(use-zulu t)

1859

(timezone *default-timezone*))

1860

   "Formats a timestring in the RFC 3339 format, a restricted form of the ISO-8601 timestring specification for Internet timestamps."

1861

(let ((rfc3339-format

1862

(if (and use-zulu

1863

(not omit-date-part)

1864

(not omit-time-part)

1865

(not omit-timezone-part))

1866

+rfc3339-format+ ; micro optimization

1867

(append

1868

(unless omit-date-part

1869

'((:year 4) #\-

1870

(:month 2) #\-

1871

(:day 2)))

1872

(unless (or omit-date-part

1873

omit-time-part)

1874

'(#\T))

1875

(unless omit-time-part

1876

'((:hour 2) #\:

1877

(:min 2) #\:

1878

(:sec 2) #\.

1879

(:usec 6)))

1880

(unless omit-timezone-part

1881

(if use-zulu

1882

'(:gmt-offset-or-z)

1883

'(:gmt-offset)))))))

1884

(format-timestring destination timestamp :format rfc3339-format :timezone timezone)))

1885

1886

(defun to-rfc3339-timestring (timestamp)

1887

(format-rfc3339-timestring nil timestamp))

1888

1889

(defun %read-timestring (stream char)

1890

(declare (ignore char))

1891

(parse-timestring

1892

(with-output-to-string (str)

1893

(loop for c = (read-char stream nil)

1894

while (and c (or (digit-char-p c) (member c '(#\: #\T #\t #\: #\- #\+ #\Z #\.))))

1895

do (princ c str)

1896

finally (when c (unread-char c stream))))

1897

:allow-missing-elements t))

1898

1899

(defun %read-universal-time (stream char arg)

1900

(declare (ignore char arg))

1901

(universal-to-timestamp

1902

(parse-integer

1903

(with-output-to-string (str)

1904

(loop for c = (read-char stream nil)

1905

while (and c (digit-char-p c))

1906

do (princ c str)

1907

finally (when c (unread-char c stream)))))))

1908

1909

(defun enable-read-macros ()

1910

"Enables the local-time reader macros for literal timestamps and universal time."

1911

(set-macro-character #\@ '%read-timestring)

1912

(set-dispatch-macro-character #\# #\@ '%read-universal-time)

1913

(values))

1914

1915

(defvar *debug-timestamp* nil)

1916

1917

(defmethod print-object ((object timestamp) stream)

1918

"Print the TIMESTAMP object using the standard reader notation"

1919

(cond

1920

(*debug-timestamp*

1921

(print-unreadable-object (object stream :type t)

1922

(format stream "~d/~d/~d"

1923

(day-of object)

1924

(sec-of object)

1925

(nsec-of object))))

1926

(t

1927

(when *print-escape*

1928

(write-char #\@ stream))

1929

(format-rfc3339-timestring stream object))))

1930

1931

(defmethod print-object ((object timezone) stream)

1932

"Print the TIMEZONE object in a reader-rejected manner."

1933

(print-unreadable-object (object stream :type t)

1934

(format stream "~:[UNLOADED~;~{~a~^ ~}~]"

1935

(timezone-loaded object)

1936

(map 'list #'subzone-abbrev (timezone-subzones object)))))

1937

1938

(defun astronomical-julian-date (timestamp)

1939

"Returns the astronomical julian date referred to by the timestamp."

1940

(- (day-of timestamp) +astronomical-julian-date-offset+))

1941

1942

(defun modified-julian-date (timestamp)

1943

"Returns the modified julian date referred to by the timestamp."

1944

(- (day-of timestamp) +modified-julian-date-offset+))

1945

1946

(declaim (notinline format-timestring))

1947

1948

(defun encode-universal-time-with-tz (sec minute hour day month year &key timezone)

1949

"Like encode-universal-time, but with a timezone object instead of a timezone offset."

1950

;; Use low level functions to prevent allocation of timestamp structures.

1951

(declare (type integer sec minute hour day month year))

1952

(unless (valid-timestamp-p 0 sec minute hour day month year)

1953

(error 'invalid-time-specification))

1954

(multiple-value-bind (ts-sec ts-day)

1955

(encode-sec-day sec minute hour day month year)

1956

(- (ts-sec-day-to-universal ts-sec ts-day)

1957

(encode-offset ts-sec

1958

ts-day

1959

(%realize-timezone (or timezone *default-timezone*))))))

1960

1961

(defun decode-universal-time-with-tz (universal &key timezone)

1962

"Like decode-universal-time, but with a timezone object instead of an timezone offset.

1963

Differences with regard to decode-universal-time:

1964

- the returned offset is the offset applicable in TIMEZONE at UNIVERSAL time,

1965

and thus corrected for DST;

1966

- returns one more value: the abbreviation of the active timezone."

1967

(multiple-value-bind (ts-sec ts-day) (universal-sec-day universal)

1968

(multiple-value-bind (offset daylight-p abbreviation)

1969

(sec-day-subtimezone ts-sec

1970

ts-day

1971

(%realize-timezone (or timezone *default-timezone*)))

1972

(multiple-value-bind (sec minute hour day month year day-of-week)

1973

(multiple-value-call #'decode-sec-day

1974

(%adjust-to-offset ts-sec ts-day offset))

1975

(values sec minute hour

1976

day month year

1977

(mod (1- day-of-week) 7) ;NB In CL: Monday = 0

1978

daylight-p

1979

(/ offset -3600) ;NB In CL: hours west

1980

abbreviation)))))