Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial commit of clsql-helper lib as shaped from our internal mudball

  • Loading branch information...
commit d907752377f2e2155e8f52941f9e8b89340b82df 1 parent 1cd0ef5
@bobbysmith007 bobbysmith007 authored
View
20 LICENSE
@@ -0,0 +1,20 @@
+;; Copyright (c) 2011 Russ Tyndall , Acceleration.net http://www.acceleration.net
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
View
16 README.mediawiki
@@ -0,0 +1,16 @@
+= CLSQL-Helper =
+
+A library providing a clutch of utilities to make working with clsql easier
+particularly in the department of dates
+
+* single interface functions that make a best effort to read/write a date in (m)any formats
+* simplified sql-expression interface
+** clsql-or(s), clsql-and(s) and clsql-exp which make building where expressions simpler
+* simplified query
+* clsql-mop help, find the primary keys of an object and query / test equality with these
+* A basic sql pretty printer, so that the code printed from
+* log-database-query , which uses the clsql printer and allows easily recording queries
+executing on a given connection
+* coersion to/from clsql data types an value
+
+
View
37 clsql-helper-slot-coercer.asd
@@ -0,0 +1,37 @@
+;; -*- lisp -*-
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package :clsql-helper.system)
+ (defpackage :clsql-helper.system
+ (:use :common-lisp :asdf))))
+
+(in-package clsql-helper.system)
+
+(defsystem :clsql-helper-slot-coercer
+ :description "A library providing a single overwritde of (setf slot-value-using-class)
+ so that obvious type coercions occur when setting slots on clsql:standard-db-objects"
+ :licence "BSD"
+ :version "0.1"
+ :components ((:file "set-slot-value-using-class"))
+ :depends-on (:clsql-helper :closer-mop))
+
+;; Copyright (c) 2011 Russ Tyndall , Acceleration.net http://www.acceleration.net
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
View
72 clsql-helper.asd
@@ -0,0 +1,72 @@
+;; -*- lisp -*-
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package :clsql-helper.system)
+ (defpackage :clsql-helper.system
+ (:use :common-lisp :asdf))))
+
+(in-package clsql-helper.system)
+
+(defsystem :clsql-helper
+ :description "A library providing a clutch of utilities to make working with clsql easier"
+ :licence "BSD"
+ :version "0.1"
+ :components ((:file "date")
+ (:file "clsql"))
+ :depends-on (:iterate :clsql :closer-mop :cl-ppcre
+ :cl-interpol :symbol-munger :alexandria))
+
+#+ASDF-SYSTEM-CONNECTIONS
+(asdf:defsystem-connection adwcodebase-clsql-postgres-connection
+ :description "the part of adwcode base dedicated to postgresql"
+ :requires (:adwcodebase :clsql-postgresql-socket :cl-ppcre)
+ :components ((:module :src
+ :components ((:file "postgres")))))
+
+#+ASDF-SYSTEM-CONNECTIONS
+(asdf:defsystem-connection adwcodebase-clsql-postgres3-connection
+ :description "the part of adwcode base dedicated to postgresql"
+ :requires (:adwcodebase :clsql-postgresql-socket3 :cl-ppcre)
+ :components ((:module :src
+ :components ((:file "postgres")))))
+
+#+ASDF-SYSTEM-CONNECTIONS
+(asdf:defsystem-connection adwcodebase-clsql-odbc-connection
+ :description "the part of adwcode base dedicated to postgresql"
+ :requires (:adwcodebase :clsql-odbc )
+ :components ((:module :src
+ :components ((:file "mssql-db-object")))))
+
+(defsystem :clsql-helper-test
+ :description "Tests for a library providing a clutch of utilities to make
+ working with clsql easier"
+ :licence "BSD"
+ :version "0.1"
+ :components ((:module :tests
+ :serial t
+ :components ((:file "clsql"))))
+ :depends-on (:clsql-helper :lisp-unit))
+
+(defmethod asdf:perform ((o asdf:test-op) (c (eql (find-system :clsql-helper))))
+ (asdf:oos 'asdf:load-op :clsql-helper-test))
+
+;; Copyright (c) 2011 Russ Tyndall , Acceleration.net http://www.acceleration.net
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
View
223 clsql.lisp
@@ -0,0 +1,223 @@
+(in-package :clsql-helper)
+(cl-interpol:enable-interpol-syntax)
+(clsql:file-enable-sql-reader-syntax)
+
+(defun clsql-exp (s)
+ (clsql-sys:sql-expression :string s))
+
+(defun db-string (s)
+ "escapes and wraps in single quotes so that the string is ready
+ to be spliced into a query (eg: with cl-interpol)"
+ (let ((it (trim-and-nullify (typecase s
+ (string s)
+ (t (princ-to-string s))))))
+ (when it
+ #?"'${(clsql-sys:sql-escape-quotes it)}'")))
+
+(defun %clsql-subclauses (clauses)
+ (iter (for c in clauses)
+ (when c
+ (collect
+ (typecase c
+ (string (clsql-exp c))
+ (T c))))))
+
+(defun clsql-ands (clauses)
+ (let ((ex (%clsql-subclauses clauses)))
+ (when ex
+ (case (length ex)
+ (1 ex)
+ (t (apply #'clsql-sys:sql-and ex))))))
+
+(defun clsql-and (&rest clauses)
+ "returns a CLSQL:SQL-AND for all non-nil clauses, no nil if there are no non-nil clauses"
+ (clsql-ands clauses))
+
+(defun clsql-ors (clauses)
+ "returns a CLSQL:SQL-AND for all non-nil clauses, no nil if there are no non-nil clauses"
+ (let ((ex (%clsql-subclauses clauses)))
+ (when ex
+ (case (length ex)
+ (1 ex)
+ (t (apply #'clsql-sys:sql-or ex))))))
+
+(defun clsql-or (&rest clauses)
+ "returns a CLSQL:SQL-AND for all non-nil clauses, no nil if there are no non-nil clauses"
+ (clsql-ors clauses))
+
+(defmethod by-col (class column colvalue)
+ "fetchs the first row for the given class by id"
+ (setf column (typecase column
+ (symbol (make-instance 'clsql-sys:sql-ident
+ :name (symbol-munger:lisp->underscores
+ column)))
+ (string (make-instance 'clsql-sys:sql-ident :name column ))
+ (t column)))
+ (first (clsql:select class
+ :where [= column colvalue]
+ :flatp T)))
+
+(defgeneric by-id (class id &optional colname)
+ (:documentation "Fetchs the first row for the given class by id")
+ (:method (class id &optional (colname [id]))
+ "direct implementation of by-id, (select class). fetchs the first row for the given class by id"
+ (by-col class colname id)))
+
+(defun primary-key-slot-names (obj)
+ (mapcar #'c2mop:slot-definition-name
+ (clsql-sys::key-slots
+ (typecase obj
+ (symbol (find-class obj))
+ (clsql-sys::standard-db-class obj)
+ (clsql-sys:standard-db-object (class-of obj))))))
+
+(defun primary-key-where-clauses ( obj )
+ "Generates a where clause based on all of the primary keys of the object
+ ex: pk1 = val1 and pk2 = val2 ...
+ "
+ (let ((keys (primary-key-slot-names obj)))
+ (values (clsql-ands
+ (iter (for key in keys)
+ (for kfn = (handler-case (fdefinition key)
+ (undefined-function ())))
+ (for kfn-v = (and (compute-applicable-methods kfn (list obj))
+ (funcall kfn obj)))
+ (for v = (or kfn-v (slot-value obj key)))
+ (collecting [= key v])))
+ keys)))
+
+(defmethod new-object-p (obj)
+ "Checks that primary keys have values and that the object
+ with those primary key values exists in the database"
+ (let* ((class (class-of obj))
+ (keys (mapcar #'c2mop:slot-definition-name
+ (clsql-sys::key-slots class))))
+ (not (and (every (lambda (k) (slot-boundp obj k)) keys)
+ (every (lambda (k) (slot-value obj k)) keys)
+ (clsql:select (class-name class)
+ :flatp T
+ :where (primary-key-where-clauses obj))))))
+
+(defmethod db-eql (x y &key (test #'equalp))
+ "Tries to determine if the objects are of the same type and have the same primary key values
+ Many times objects which pass new-objectp are db-eql ,but once saved are no longer db-eql (due to using serial pkey)"
+ (or (and (null x) (null y))
+ (and
+ (eql (class-of x) (class-of y))
+ ;; make sure all the keys have the same values
+ (iter (for key-def in (clsql-sys::key-slots (class-of x)))
+ (for key = (c2mop:slot-definition-name key-def))
+ (for s1 = (slot-boundp x key))
+ (for s2 = (slot-boundp y key))
+ ;;true when either both slots are unbound or both slots have the same value
+ (always (or (not (or s1 s2))
+ (and s1 s2
+ (funcall test (slot-value x key)
+ (slot-value y key)))))))))
+
+(defun pretty-print-sql (sql-command)
+ (when (and sql-command (stringp sql-command))
+ (let ((paren-cnt 0)
+ wrote-a-newline
+ ;; A scanner for top level keywords, secondary keywords
+ ;; and sub expressions (as by parens)
+ (scanner (load-time-value
+ (cl-ppcre:create-scanner
+ #?r"(?:\s+(?:(select|insert|update|delete|exec)|(from|where|order|group|left join|full join|outer join|join|values|on|limit))\s+)|(\()|(\))|(\n)"
+ :case-insensitive-mode T))))
+ (flet ((spaces (&optional (extra-n 1))
+ "Creates a string with the correct indent in it"
+ (make-string (+ extra-n (* 2 paren-cnt))
+ :initial-element #\space )))
+ (cl-ppcre:regex-replace-all
+ scanner sql-command
+ (lambda (m g1 g2 g3 g4 g5)
+ (declare (ignore m))
+ (let ((wnl wrote-a-newline))
+ (setf wrote-a-newline nil)
+ (cond
+ ((or g1 g2) ;; we got a sql keyword, or subkeyword
+ ;; if we already wrote a new line, we dont need another
+ (let ((newline (if wnl "" #\newline)))
+ #?"${newline}${ (spaces (if g1 1 3)) }${ (or g1 g2) } "))
+ (g3 (incf paren-cnt) g3) ;; got an open paren
+ (g4 ;; close paren
+ (when (> paren-cnt 0) (decf paren-cnt))
+ ;; if this paren is alone on a line indent it
+ #?"${ (if wnl (spaces) "") }${g4}" )
+ ;; we wrote a newline so we may not need to write another
+ (g5 (setf wrote-a-newline T) g5)
+ (T
+ "" ))))
+ :simple-calls T)))))
+
+(defmacro log-database-command ((log-fn-name &optional (database 'clsql:*default-database*)) &body body)
+ "MUST BE Inside a database connection, creates a lexical scope in which all sql commands
+ executed on this connection are logged to a specific logger
+
+ tries to format such that it will be readable in the log
+
+ log-fn-name is a function/macro name that will be called with a string/array as
+ (log-fn-name stuff)
+ "
+ (alexandria:with-unique-names (str record results)
+ `(let* (,results
+ (,record (make-array 60 :fill-pointer 0 :adjustable T :element-type 'base-char)))
+ (with-output-to-string (,str ,record)
+ (setf (clsql-sys:command-recording-stream ,database)
+ (make-broadcast-stream ,str)
+ ,results
+ (unwind-protect
+ (progn ,@body)
+ (setf (clsql-sys:command-recording-stream ,database) nil)
+ (setf ,record (pretty-print-sql ,record))
+ (,log-fn-name ,record))))
+ ,results)))
+
+(defun coerce-to-clsql-table-name (table)
+ "based on what is passed in, tries to figure out what the table name is"
+ (let ((cls (ignore-errors (find-class table))))
+ (typecase table
+ (symbol (if cls
+ (clsql-sys::view-table cls)
+ (symbol-munger:lisp->underscores table :capitalize nil)))
+ (clsql-sys::standard-db-class (clsql-sys::view-table table))
+ (clsql-sys::standard-db-object
+ (class-of (clsql-sys::view-table table)) )
+ (string table))))
+
+(defun coerce-value-to-db-type (val db-type)
+ (cond
+ ((subtypep db-type 'clsql-sys:varchar)
+ (trim-and-nullify (princ-to-string val)))
+ ((subtypep db-type 'integer)
+ (etypecase val
+ (string (parse-integer val))
+ (integer val)))
+ ((subtypep db-type 'double-float)
+ (etypecase val
+ (string (relaxed-parse-float val))
+ (number val)))
+ ((subtypep db-type 'number)
+ (etypecase val
+ (string (relaxed-parse-float val))
+ (number val)))
+ ((subtypep db-type 'clsql:date) (convert-to-clsql-date val))
+ ((subtypep db-type 'clsql:wall-time ) (convert-to-clsql-datetime val))
+ ((subtypep db-type 'boolean)
+ (typecase val
+ (string (not (null (member val (list "T" "true" "1" "y" "yes") :test #'string-equal))))
+ (T val)))
+ ((subtypep db-type 'clsql-sys:duration )
+ (error "NO COERCION IMPLEMENTED"))
+ (T (error "NO COERCION IMPLEMENTED"))))
+
+(defun format-value-for-database (d &optional stream)
+ "prints a correctly sql escaped value for postgres"
+ (etypecase d
+ (null (format stream "null"))
+ (string (format stream "'~a'" (clsql-sys:sql-escape-quotes d)))
+ (integer (format stream "~D" d))
+ (float (format stream "~F" d))
+ (clsql-sys:date (format stream "'~a'" (iso8601-datestamp d)))
+ (clsql-sys:wall-time (format stream "'~a'" (clsql-sys:iso-timestring d)))))
View
305 date.lisp
@@ -0,0 +1,305 @@
+(cl:defpackage :clsql-helper
+ (:use :cl :cl-user :iter)
+ (:export
+ ;; date stuff
+ #:current-sql-date #:current-sql-time
+ #:print-nullable-date #:print-nullable-datetime
+ #:date-day #:date-year #:date-month
+ #:month-string #:month-day-string
+ #:convert-to-clsql-date #:convert-to-clsql-datetime
+ #:clsql-datetime-equal
+ #:clsql-date/times->utime
+ #:clsql-date/times->local-time
+ #:iso8601-datestamp
+ #:iso8601-timestamp
+
+ ;; rest
+ #:clsql-exp #:db-string #:clsql-ands #:clsql-and
+ #:clsql-ors #:clsql-or
+ #:by-id #:by-col
+ #:primary-key-slot-names #:primary-key-where-clauses
+ #:db-eql #:new-object-p #:save-failed
+ #:pretty-print-sql
+ #:coerce-value-to-db-type #:format-value-for-database
+ #:coerce-to-clsql-table-name
+ #:log-database-command
+ ))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (find-package :local-time)
+ (pushnew :local-time *features*)))
+
+(in-package :clsql-helper)
+(cl-interpol:enable-interpol-syntax)
+(clsql:file-enable-sql-reader-syntax)
+
+(defvar *clsql-codebase-loaded* T)
+
+;;;; UTILS
+(defparameter +common-white-space-trimbag+
+ '(#\space #\newline #\return #\tab #\no-break_space))
+
+(defun trim-whitespace (s)
+ (string-trim +common-white-space-trimbag+ s))
+
+(defun trim-and-nullify (s)
+ "trims the whitespace from a string returning nil
+ if trimming produces an empty string or the string 'nil' "
+ (when s
+ (let ((s (trim-whitespace s)))
+ (cond ((zerop (length s)) nil)
+ ((string-equal s "nil") nil)
+ ((string-equal s "null") nil)
+ (T s)))))
+
+(defmethod relaxed-parse-float (str &key (type 'double-float))
+ "trys to read a value we hope to be a floating point number returns nil on failure
+
+ The goal is to allow reading strings with spaces commas and dollar signs in them correctly
+ "
+ (etypecase str
+ (null nil)
+ (float str)
+ (number (float str (ecase type
+ (single-float 0.0)
+ ((float double-float) 0.0d0))))
+ ((or string symbol)
+ (let* ((str (cl-ppcre:regex-replace-all #?r"\s|\$|\,|\%" (string str) ""))
+ (*read-eval* nil)
+ (*read-default-float-format* type))
+ (ignore-errors
+ (coerce (read-from-string str) type))))))
+;;;;
+
+(defun current-sql-date ()
+ "current date"
+ (clsql-sys:get-date))
+
+(defun current-sql-time ()
+ "current date and time"
+ (clsql-sys:get-time))
+
+(defun print-nullable-date (field)
+ "if the date exists, prints m?m/d?d/yyyy"
+ (when field
+ (typecase field
+ (string field)
+ (T (clsql:print-date
+ (typecase field
+ (clsql-sys:date (clsql-sys::date->time field))
+ (clsql-sys:wall-time field))
+ :day)))))
+
+(defmethod print-object ((o clsql-sys:date) stream)
+ (let ((date (print-nullable-date o)))
+ (if *print-escape*
+ (print-unreadable-object (o stream :type T :identity T)
+ (format stream "~A" date))
+ (format stream "~A" date))))
+
+(defmethod date-day (d)
+ (etypecase d
+ (clsql-sys:date
+ (third (multiple-value-list (clsql-sys:date-ymd d))))
+ (clsql-sys:wall-time
+ (third (multiple-value-list (clsql-sys:time-ymd d))))
+ ((or string integer)
+ (date-day (convert-to-clsql-datetime d)))
+ #+local-time
+ (local-time:timestamp (local-time:timestamp-day d))
+ (null nil)
+ ))
+
+(defmethod date-year (d )
+ (etypecase d
+ (clsql-sys:date (clsql-sys:date-ymd d))
+ (clsql-sys:wall-time (clsql-sys:time-ymd d))
+ ((or string integer)
+ (date-year (convert-to-clsql-datetime d)))
+ #+local-time
+ (local-time:timestamp (local-time:timestamp-year d))
+ (null nil)))
+
+(defmethod date-month (d)
+ (etypecase d
+ (clsql-sys:date
+ (second (multiple-value-list (clsql-sys:date-ymd d))))
+ (clsql-sys:wall-time
+ (second (multiple-value-list (clsql-sys:time-ymd d))))
+ ((or string integer)
+ (date-month (convert-to-clsql-datetime d)))
+ #+local-time
+ (local-time:timestamp (local-time:timestamp-month d))
+ (null nil)))
+
+(defun month-string (d)
+ "Converts the date to the full name, January, February,etc"
+ (let ((d (date-month d)))
+ (when d (clsql-sys:month-name d))))
+
+(defun month-day-string (d)
+ "prints dates as January 3"
+ (let ((d (date-day d))
+ (m (month-string d)))
+ (when (and d m) #?"${m} ${d}")))
+
+(defun print-nullable-datetime (field)
+ "if the date exists, prints mm/dd/yyyy hh:mm:ss"
+ (let ((*print-pretty* nil))
+ (when field
+ (typecase field
+ (string field)
+ (T (multiple-value-bind (usec second minute hour day month year)
+ (clsql-sys:decode-time (convert-to-clsql-datetime field))
+ (declare (ignore usec))
+ (format nil "~2,'0d/~2,'0d/~4,'0d ~2,'0d:~2,'0d:~2,'0d"
+ month day year hour minute second)))))))
+
+(defmethod print-object ((o clsql:wall-time) stream)
+ (let ((date (print-nullable-datetime o)))
+ (if *print-escape*
+ (print-unreadable-object (o stream :type T :identity T)
+ (format stream "~A" date))
+ (format stream "~A" date))))
+
+(defun clsql-datetime-equal (x y)
+ "Tries to handle full datetime equality reguardless of the format
+ (string datestamp, date, datetime, utime)"
+ (flet ((cast (x)
+ (typecase x
+ (integer (clsql-sys:utime->time x))
+ (clsql-sys:date (clsql-sys::date->time x))
+ (string (convert-to-clsql-datetime x))
+ (T x))))
+ (equalp (cast x) (cast y))))
+
+(defvar *iso8601-timezone* nil)
+(defvar *iso8601-microseconds* nil)
+(defvar *iso8601-date-time-separator* " ")
+(defvar *iso8601-time-separator* ":")
+(defvar *iso8601-date-separator* "-")
+
+(defmethod iso8601-datestamp (d)
+ (typecase d
+ ((or clsql-sys:wall-time clsql-sys:date)
+ (format nil "~4,'0D~A~2,'0D~A~2,'0D"
+ (date-year d) *iso8601-date-separator* (date-month d)
+ *iso8601-date-separator* (date-day d)))
+ ((or string integer) (iso8601-datestamp (convert-to-clsql-datetime d)))
+ (null nil)))
+
+(defmethod iso8601-timestamp (d)
+ "CLSQL has a function (I wrote) to do this, but I wanted more flexibility in output
+ so that I could use this in more situations
+
+ clsql:iso-timestamp is used only to write to database backends, so a very strict ISO
+ is fine
+ "
+ (typecase d
+ ((or clsql-sys:wall-time clsql-sys:date string integer
+ #+local-time local-time:timestamp)
+ (multiple-value-bind (usec second minute hour day month year)
+ (clsql-sys:decode-time (convert-to-clsql-datetime d))
+ ;; oh yeah, we love recursive format processing
+ ;; http://www.lispworks.com/documentation/HyperSpec/Body/22_cgf.htm
+ (apply
+ #'format nil "~4,'0D~A~2,'0D~A~2,'0D~A~2,'0D~a~2,'0D~A~2,'0D~?~?"
+ (nconc
+ (list year *iso8601-date-separator* month
+ *iso8601-date-separator* day
+ *iso8601-date-time-separator*
+ hour *iso8601-time-separator*
+ minute *iso8601-time-separator*
+ second)
+ (if *iso8601-microseconds*
+ (list ".~6,'0D" (list usec))
+ (list "" ()))
+ (cond
+ ((eql *iso8601-timezone* T) (list "~A" (list 'Z)))
+ ((stringp *iso8601-timezone*) (list "~A" (list *iso8601-timezone*)))
+ (T (list "" ())))))))
+ (null nil)))
+
+(defparameter +date-sep+ "(?:/|-|\\.|:)")
+
+(defparameter +date-time-regex+
+ (cl-ppcre:create-scanner
+ #?r"^(\d{1,2})${ +date-sep+ }(\d{1,2})${ +date-sep+ }(\d{2,4})(?:\s*(\d{1,2})${ +date-sep+ }(\d{1,2})(?:${ +date-sep+ }(\d{1,2}))?\s*((?:a|p)m\.?)?)?"
+ :case-insensitive-mode t))
+
+(defparameter +iso-8601-ish-regex-string+
+ #?r"^(\d{2,4})${ +date-sep+ }(\d{1,2})${ +date-sep+ }(\d{1,2})(?:(?:\s*|T)(\d{1,2})${ +date-sep+ }(\d{1,2})(?:${ +date-sep+ }(\d{1,2}))?\s*((?:a|p)m\.?)?(?:Z|,,0|(?:-|\+)\d{1,2}:?\d{2}?)?)?")
+
+(defparameter +iso-8601-ish-regex+
+ (cl-ppcre:create-scanner +iso-8601-ish-regex-string+ :case-insensitive-mode t))
+
+(defun convert-to-clsql-datetime (val )
+ "Converts a string timestamp into a clsql date time object
+ Makes every possible effort to understand your date that will invariably be in some format it wont understand."
+ (macrolet ((regex-date-to-clsql-date ()
+ "Pretty fugly variable capture, but what are you gonna do.
+ I have the exact same code twice with like 6 vars to pass"
+ `(let ((hour (if (and h (< h 12)
+ (string-equal am/pm "PM"))
+ (+ 12 h)
+ h))
+ (year (and y
+ (cond
+ ((< y 50) (+ y 2000))
+ ((< y 100) (+ y 1900))
+ (T y)))))
+ (clsql:make-time :year year :month mon :day d
+ :hour (or hour 0) :minute (or m 0) :second (or s 0)))))
+ (typecase val
+ (clsql:date (clsql-sys::date->time val))
+ (clsql:wall-time val)
+ (integer (clsql-sys::utime->time val))
+ #+local-time
+ (local-time:timestamp (local-time->clsql-datetime val))
+ (string
+ (or ; as best I can tell these just suck
+ ;(ignore-errors (clsql-sys:parse-date-time val))
+ ;(ignore-errors (clsql-sys:parse-timestring val))
+ (cl-ppcre:register-groups-bind ((#'parse-integer mon d y h m s) am/pm)
+ (+date-time-regex+ val)
+ (regex-date-to-clsql-date))
+ (cl-ppcre:register-groups-bind ((#'parse-integer y mon d h m s) am/pm)
+ (+iso-8601-ish-regex+ val)
+ (regex-date-to-clsql-date)
+ ))))))
+
+(defun convert-to-clsql-date (val)
+ (typecase val
+ (null nil)
+ (clsql:date val)
+ (clsql-sys::wall-time (clsql-sys::time->date val))
+ (t (convert-to-clsql-date (convert-to-clsql-datetime val)))))
+
+#+local-time
+(defun clsql-date/times->local-time (obj)
+ "obj is either a wall-time or a date"
+ (apply #'local-time:encode-timestamp
+ ;;we dont want day of week
+ (multiple-value-bind (usec second minute hour day month year)
+ (clsql-sys:decode-time (convert-to-clsql-datetime obj))
+ (list (* 1000 usec) second minute hour day month year ))))
+
+#+local-time
+(defun local-time->clsql-datetime (obj)
+ "obj is either a wall-time or a date"
+ (apply #'clsql-sys:make-time
+ ;;we dont want day of week
+ (multiple-value-bind (nsec second minute hour day month year)
+ (clsql-sys:decode-time (convert-to-clsql-datetime obj))
+ (list year month day hour minute second (floor (/ 1000 nsec))))))
+
+(defun clsql-date/times->utime (obj)
+ "obj is either a wall-time or a date
+
+ if you are looking for the other it is clsql-sys:utime->time
+ "
+ (apply #'encode-universal-time
+ (multiple-value-bind (usec second minute hour day month year)
+ (clsql-sys:decode-time (convert-to-clsql-datetime obj))
+ (declare (ignore usec))
+ (list second minute hour day month year 0))))
View
121 mssql-db-object.lisp
@@ -0,0 +1,121 @@
+(in-package :adwutils)
+(cl-interpol:enable-interpol-syntax)
+
+(defvar *clsql-odbc-codebase-loaded* T)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export 'clsql::mssql-db-object :clsql)
+ (export 'clsql::mssql-db-view :clsql))
+
+(eval-always
+ (defclass clsql:mssql-db-object (clsql-sys:standard-db-object)
+ nil
+ (:metaclass clsql-sys::standard-db-class)))
+
+(defmethod print-object ((o CLSQL:MSSQL-DB-OBJECT) s)
+ "Print the database object, and a couple of the most common identity slots."
+ (print-unreadable-object (o s :type t :identity t)
+ (awhen (ignore-errors (accessor-value-by-name o "id"))
+ (format s "db-id:~a " it))
+ (awhen (ignore-errors (accessor-value-by-name o "title"))
+ (format s "Title:~s " it))
+ (awhen (ignore-errors (accessor-value-by-name o "name"))
+ (format s "Name:~s " it))
+ ))
+
+(defmethod clsql-sys::choose-database-for-instance ((object clsql::mssql-db-object) &optional database)
+ (or database clsql-sys:*default-database*))
+
+(defclass clsql:mssql-db-view (clsql-sys:standard-db-object)
+ nil
+ (:metaclass clsql-sys::standard-db-class))
+
+(defmethod clsql::stored-slot-p
+ ((slot-def clsql-sys::view-class-effective-slot-definition)
+ &optional (include-key-slot t))
+ (if include-key-slot
+ (find (clsql-sys::view-class-slot-db-kind slot-def) '(:key :base))
+ (eql :base (clsql-sys::view-class-slot-db-kind slot-def))))
+
+(defmethod clsql::stored-slotdefs ((obj clsql::standard-db-object)
+ &optional (include-key-slot t))
+ (clsql::stored-slotdefs (class-of obj) include-key-slot))
+
+(defmethod clsql::stored-slotdefs ((class clsql-sys::standard-db-class)
+ &optional (include-key-slot t))
+ (remove-if #'(lambda (sl)
+ (not (clsql::stored-slot-p sl include-key-slot)))
+ (clsql-sys::ordered-class-slots class)))
+
+(defmethod clsql-sys:update-records-from-instance
+ ((obj clsql:mssql-db-object) &key clsql-sys:database &allow-other-keys)
+ (let ((slots (remove-if
+ #'(lambda (sd)
+ (or (not (slot-boundp obj (closer-mop:slot-definition-name sd)))
+ (member :identity (ensure-list (clsql-sys::view-class-slot-db-constraints sd)))))
+ (clsql::stored-slotdefs obj T))))
+ (clsql:update-record-from-slots obj slots :database clsql-sys:database)))
+
+(defmethod clsql-sys:update-record-from-slots :after
+ ((obj clsql:mssql-db-object) slots &key clsql-sys:database)
+ "After effecting the database record, if the key-slot is empty then use
+SCOPE_IDENTITY to fill it. If > 1 key-slot, this won't do anything."
+ (arnesi:when-bind key-slots
+ (clsql-sys::key-slots (class-of obj))
+ (if (= 1 (length key-slots))
+ (let ((key-slot-name (sb-mop:slot-definition-name
+ (first key-slots))))
+ (unless (and
+ (slot-boundp obj key-slot-name)
+ (slot-value obj key-slot-name))
+ (setf (slot-value obj key-slot-name)
+ (let ((new-id (car (clsql-sys:query
+ "SELECT SCOPE_IDENTITY()"
+ :flatp t
+ :database
+ (clsql-sys::choose-database-for-instance
+ obj
+ clsql-sys:database)))))
+ (typecase new-id
+ (number new-id)
+ (string (parse-integer new-id :junk-allowed T))))))))))
+
+(defmethod clsql-sys:update-record-from-slots
+ ((o clsql:mssql-db-view) slots &key &allow-other-keys)
+ "By default views shouldn't be updatable, so specialize a method to signal an error."
+ (error "MSSQL view ~a is not updatable because it represents a view not a table."
+ (class-of o)))
+
+(defun mssql-db-type-from-lisp-types (data-table)
+ (iter
+ (for i from 0)
+ (for lisp-type in (column-types data-table))
+ (collect
+ (cond ((subtypep lisp-type 'float) "decimal (19,9)")
+ ((subtypep lisp-type 'integer)
+ (iter
+ (with thresh = (expt 2 15))
+ (for int in (data-table-value data-table :col-idx i))
+ (when int
+ (minimizing int into min)
+ (maximizing int into max))
+ (finally
+ (return
+ (if (<= (- thresh) (or min 0) (or max 0) thresh)
+ "int"
+ "bigint"
+ )))))
+ ((subtypep lisp-type 'string)
+ (let ((next-size
+ (next-highest-power-of-two
+ (iter (for s in (data-table-value data-table :col-idx i))
+ (maximizing (length s))))))
+ (cond
+ ((< 8000 next-size) "text")
+ ((< next-size 128) #?"varchar(128)")
+ (t #?"varchar(${next-size})"))))
+ ((or (subtypep lisp-type 'clsql-sys:wall-time)
+ (subtypep lisp-type 'clsql-sys:date))
+ "datetime")
+ (T (error "Couldnt map type"))))))
+
View
78 postgres.lisp
@@ -0,0 +1,78 @@
+(in-package :net.acceleration.utils)
+(cl-interpol:enable-interpol-syntax)
+
+(defvar *clsql-pg-codebase-loaded* T)
+
+(eval-always
+ (defclass pg-db-obj ()
+ ()
+ (:METACLASS CLSQL-SYS::STANDARD-DB-CLASS)))
+
+(defmethod set-through-accessor ((obj pg-db-obj) name value)
+ (call-next-method)
+ (let ((slot-def (class-slot-by-name (class-of obj) name)))
+ (when-bind db-info (clsql-sys::view-class-slot-db-info slot-def)
+ (let ((hk (gethash :home-key db-info))
+ (fk (gethash :foreign-key db-info))
+ (cls (gethash :join-class db-info)))
+ (when (typep value cls)
+ (ignore-errors ;; just make an attempt to set the backing slot
+ (set-through-accessor obj hk (accessor-value-by-name value fk))))))))
+
+(defmethod clsql-sys::choose-database-for-instance ((object pg-db-obj) &optional database)
+ (or database clsql-sys:*default-database*))
+
+(defmethod clsql:update-record-from-slots :after ((obj pg-db-obj) slots &key clsql:database)
+ "After effecting the database record, if the key-slot is empty then use
+curval(sequence) to fill it. If > 1 key-slot, this won't do anything."
+ (arnesi:when-bind key-slots
+ (clsql-sys::key-slots (class-of obj))
+ (if (= 1 (length key-slots))
+ (let ((key-slot-name (sb-mop:slot-definition-name
+ (first key-slots))))
+ (unless (and (slot-boundp obj key-slot-name)
+ (slot-value obj key-slot-name))
+ (setf (slot-value obj key-slot-name)
+ (car (clsql-sys:query
+ #?"SELECT currval('${(clsql:view-table (class-of obj))}_id_seq')"
+ :flatp t
+ :database
+ (clsql-sys::choose-database-for-instance
+ obj
+ clsql-sys:database)))))))))
+
+(defmethod print-object ((o pg-db-obj) (s stream))
+ "Print the database object, and a couple of the most common identity slots."
+ (print-unreadable-object (o s :type t :identity t)
+ (awhen (ignore-errors (accessor-value-by-name o "id"))
+ (format s "db-id:~a " it))
+ (awhen (ignore-errors (accessor-value-by-name o "title"))
+ (format s "Title:~a " it))
+ (awhen (ignore-errors (accessor-value-by-name o "name"))
+ (format s "Name:~a " it))
+ ))
+
+(defun format-value-for-postgres (d &optional stream)
+ "prints a correctly sql escaped value for postgres"
+ (format-value-for-database d stream))
+(export 'format-value-for-postgres)
+
+
+(defun copy-table ( table-from table-to )
+ "Makes a copy of a table to a new table in the same database.
+ NB: Not a very quick way to copy tables"
+ (setf table-from (coerce-to-clsql-table-name table-from)
+ table-to (coerce-to-clsql-table-name table-to))
+ (clsql-sys:execute-command #?"CREATE TABLE ${table-to} (like ${table-from} INCLUDING DEFAULTS INCLUDING CONSTRAINTS INCLUDING INDEXES);")
+ (clsql-sys:execute-command #?"INSERT INTO ${table-to} (SELECT * FROM ${table-from});"))
+(export 'copy-table)
+
+(defun postgres-db-type-from-lisp-type (lisp-type)
+ "Given a lisp data-type make up a postgres type to match"
+ (cond ((subtypep lisp-type 'float) "double precision")
+ ((subtypep lisp-type 'integer) "int8")
+ ((subtypep lisp-type 'string) "text")
+ ((or (subtypep lisp-type 'clsql-sys:wall-time)
+ (subtypep lisp-type 'clsql-sys:date))
+ "timestamp with time zone")
+ (T (error "Couldnt map type"))))
View
43 set-slot-value-using-class.lisp
@@ -0,0 +1,43 @@
+(in-package :clsql-helper)
+(cl-interpol:enable-interpol-syntax)
+
+(defmethod (setf closer-mop:slot-value-using-class)
+ (new
+ (class clsql-sys::standard-db-class)
+ (object clsql-sys:standard-db-object)
+ (slot closer-mop:standard-effective-slot-definition))
+ "Ensure that if we try to set a slot on a db-object to a value whos type doesnt match
+ that we coerce that value to an appropriate clsql type
+
+ Conversions:
+ strings to date
+ numbers to double-float
+ symbols to strings
+
+ "
+ (if (clsql-sys::specified-type slot)
+ (cond
+ ((and (typep new 'string) (< 0 (length new)))
+ (cond
+ ((subtypep (clsql-sys::specified-type slot) 'clsql-sys:wall-time)
+ (setf (closer-mop:slot-value-using-class
+ class object slot)
+ (convert-to-clsql-datetime new)))
+ ((subtypep (clsql-sys::specified-type slot) 'clsql-sys:date)
+ (setf (closer-mop:slot-value-using-class
+ class object slot)
+ (convert-to-clsql-date new)))
+ (T (call-next-method))))
+ ((and (typep new 'number)
+ (not (typep new 'double-float))
+ (clsql-sys::specified-type slot)
+ (subtypep (clsql-sys::specified-type slot) 'double-float))
+ (setf (closer-mop:slot-value-using-class class object slot)
+ (coerce new 'double-float)))
+
+ ;; we specified a string, we have a value and the value isnt a string
+ ((and new (not (stringp new)) (subtypep (clsql-sys::specified-type slot) 'string))
+ (setf (closer-mop:slot-value-using-class class object slot)
+ (princ-to-string new)))
+ (t (call-next-method)))
+ (call-next-method)))
View
52 tests/clsql.lisp
@@ -0,0 +1,52 @@
+(defpackage :clsql-helper-test
+ (:use :cl :clsql-helper :lisp-unit :iter))
+
+(in-package :clsql-helper-test)
+(cl-interpol:enable-interpol-syntax)
+
+(define-test test-clsql-parse-and-print
+ (let ((dates
+ `(("7/1/2005"
+ "07/01/2005 00:00:00" "7/1/2005" "2005-07-01" "2005-07-01 00:00:00")
+ ("12/22/2009"
+ "12/22/2009 00:00:00" "12/22/2009" "2009-12-22" "2009-12-22 00:00:00")
+ ("09/02/2009"
+ "09/02/2009 00:00:00" "9/2/2009" "2009-09-02" "2009-09-02 00:00:00")
+ ("09/02/09"
+ "09/02/2009 00:00:00" "9/2/2009" "2009-09-02" "2009-09-02 00:00:00")
+ ("09/02/09 12:15"
+ "09/02/2009 12:15:00" "9/2/2009" "2009-09-02" "2009-09-02 12:15:00")
+ ("9/2/2009 12:15:02"
+ "09/02/2009 12:15:02" "9/2/2009" "2009-09-02" "2009-09-02 12:15:02")
+ ("9/2/2009 12:15:02 PM"
+ "09/02/2009 12:15:02" "9/2/2009" "2009-09-02" "2009-09-02 12:15:02")
+ ("9/2/2009 11:15:02 PM"
+ "09/02/2009 23:15:02" "9/2/2009" "2009-09-02" "2009-09-02 23:15:02")
+ ("9/2/2009 11:15:02 AM"
+ "09/02/2009 11:15:02" "9/2/2009" "2009-09-02" "2009-09-02 11:15:02")
+ ("9/2/2009 11:15:02"
+ "09/02/2009 11:15:02" "9/2/2009" "2009-09-02" "2009-09-02 11:15:02")
+ ("2009-02-20"
+ "02/20/2009 00:00:00" "2/20/2009" "2009-02-20" "2009-02-20 00:00:00")
+ ("2009-02-20 11:15:02"
+ "02/20/2009 11:15:02" "2/20/2009" "2009-02-20" "2009-02-20 11:15:02")
+ ("2009-02-20 11:15:02,,0"
+ "02/20/2009 11:15:02" "2/20/2009" "2009-02-20" "2009-02-20 11:15:02")
+ ("2009-02-20T11:15:02Z"
+ "02/20/2009 11:15:02" "2/20/2009" "2009-02-20" "2009-02-20 11:15:02" )
+ ("2009-12-20T11:15:02Z"
+ "12/20/2009 11:15:02" "12/20/2009" "2009-12-20" "2009-12-20 11:15:02" )
+ ("432" nil)
+ )))
+ (iter (for (d c-time c-date c-iso-date c-iso-time) in dates)
+ (for dt = (convert-to-clsql-datetime d))
+ (for stime = (print-nullable-datetime dt))
+ (for sdate = (print-nullable-date dt))
+ (for iso-date = (iso8601-datestamp dt))
+ (for iso-time = (iso8601-timestamp dt))
+ (assert-equal c-time stime d)
+ (assert-equal c-date sdate d)
+ (assert-equal c-iso-time iso-time d)
+ (assert-equal c-iso-date iso-date d))))
+
+(run-tests)
Please sign in to comment.
Something went wrong with that request. Please try again.