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

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.

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
+ 
+

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.

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.

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)))))