r9199: fold clsql-base and clsql-base-sys into clsql-base

[clsql.git] / base / time.lisp

diff --git a/base/time.lisp b/base/time.lisp
index 6891188a656769ba544cf47de8f34fa49645f6e0..0b70f2c6f28b9610f7b7ac9875b38dfa72da3f4a 100644 (file)
--- a/base/time.lisp
+++ b/base/time.lisp
@@ -15,7 +15,7 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(in-package #:clsql-base-sys)
+(in-package #:clsql-base)
 
 ;; ------------------------------------------------------------
 ;; Months
@@ -109,13 +109,17 @@
   (%make-wall-time :mjd (time-mjd time)
                    :second (time-second time)))
 
-(defun get-time ()
+(defun utime->time (utime)
   "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
   (multiple-value-bind (second minute hour day mon year)
-      (decode-universal-time (get-universal-time))
+      (decode-universal-time utime)
     (make-time :year year :month mon :day day :hour hour :minute minute
                :second second)))
 
+(defun get-time ()
+  "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
+  (utime->time (get-universal-time)))
+
 (defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0)
                            (second 0))
   (multiple-value-bind (minute-add second-60)
@@ -160,26 +164,27 @@ month, year, integer day-of-week"
 
 ;; duration specific
 (defun duration-reduce (duration precision &optional round)
-     (:second
-      (+ (duration-second duration)
-         (* (duration-reduce duration :minute) 60)))
-     (:minute
-      (+ (if round
-            (floor (duration-second duration) 30)
-            0)
-        (duration-minute duration)
-         (* (duration-reduce duration :hour) 60)))
-     (:hour
-      (+ (if round
-            (floor (duration-minute duration) 30)
-            0)
-        (duration-hour duration)
-         (* (duration-reduce duration :day) 24)))
-     (:day
-      (+ (if round
-            (floor (duration-hour duration) 12)
-            0)
-        (duration-day duration))))
+  (ecase precision
+    (:second
+     (+ (duration-second duration)
+       (* (duration-reduce duration :minute) 60)))
+    (:minute
+     (+ (if round
+           (floor (duration-second duration) 30)
+           0)
+       (duration-minute duration)
+       (* (duration-reduce duration :hour) 60)))
+    (:hour
+     (+ (if round
+           (floor (duration-minute duration) 30)
+           0)
+       (duration-hour duration)
+       (* (duration-reduce duration :day) 24)))
+    (:day
+     (+ (if round
+           (floor (duration-hour duration) 12)
+           0)
+       (duration-day duration)))))
 
 
 ;; ------------------------------------------------------------
@@ -679,31 +684,32 @@ TIME2."
                     (internal-separator " "))
   "produces on stream the timestring corresponding to the wall-time
 with the given options"
-  (multiple-value-bind (second minute hour day month year dow)
-      (decode-time time)
-    (case format
-      (:pretty
-       (format stream "~A ~A, ~A ~D, ~D"
-               (pretty-time hour minute)
-               (day-name dow)
-               (month-name month)
-               day
-               year))
-      (:short-pretty
-       (format stream "~A, ~D/~D/~D"
-               (pretty-time hour minute)
-               month day year))
-      (:iso
-       (let ((string (iso-timestring time)))
-         (if stream
-             (write-string string stream)
+  (let ((*print-circle* nil))
+    (multiple-value-bind (second minute hour day month year dow)
+       (decode-time time)
+      (case format
+       (:pretty
+        (format stream "~A ~A, ~A ~D, ~D"
+                (pretty-time hour minute)
+                (day-name dow)
+                (month-name month)
+                day
+                year))
+       (:short-pretty
+        (format stream "~A, ~D/~D/~D"
+                (pretty-time hour minute)
+                month day year))
+       (:iso
+        (let ((string (iso-timestring time)))
+          (if stream
+              (write-string string stream)
              string)))
-      (t
-       (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D"
-               year date-separator month date-separator day
-               internal-separator hour time-separator minute time-separator
-               second)))))
-
+       (t
+        (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D"
+                year date-separator month date-separator day
+                internal-separator hour time-separator minute time-separator
+                second))))))
+  
 (defun pretty-time (hour minute)
   (cond
    ((eq hour 0)
@@ -779,6 +785,9 @@ with the given options"
         (t
          (values hours "AM"))))
 
+(defgeneric to-string (val &rest keys)
+  )
+
 (defmethod to-string ((time wall-time) &rest keys)
   (destructuring-bind (&key (style :daytime) &allow-other-keys)
       keys
@@ -977,6 +986,12 @@ rules"
     (when (and year (< 1500 year 2500))
       (make-time :year year))))
 
+(defun parse-integer-insensitively (string)
+  (let ((start (position-if #'digit-char-p string))
+        (end   (position-if #'digit-char-p string :from-end t)))
+    (when (and start end)
+      (parse-integer (subseq string start (1+ end)) :junk-allowed t))))
+
 (defvar *roman-digits*
   '((#\M . 1000)
     (#\D . 500)
@@ -988,8 +1003,8 @@ rules"
 
 (defun extract-roman (string &aux parse)
   (dotimes (x (length string))
-    (when-bind (val (get-alist (aref string x) *roman-digits*))
-      (when (and parse (< (car parse) val))
+    (let ((val (cdr (assoc (aref string x) *roman-digits*))))
+      (when (and val parse (< (car parse) val))
         (push (- (pop parse)) parse))
       (push val parse)))
   (apply #'+ parse))