Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
  • 3 commits
  • 4 files changed
  • 0 comments
  • 2 contributors
39  psr/test.php
... ...
@@ -0,0 +1,39 @@
  1
+<?php // This file is protected by copyright law and provided under license. Reverse engineering of this file is strictly prohibited.
  2
+$current_file=__FILE__;
  3
+$current_line=__LINE__;
  4
+
  5
+$current_file="index.php";
  6
+$current_line=2;
  7
+
  8
+$_88=88;
  9
+
  10
+$fd_current_file=fopen($current_file,'rb');
  11
+
  12
+while(--$current_line)
  13
+  fgets($fd_current_file,1024);
  14
+
  15
+fgets($fd_current_file,4096);
  16
+
  17
+/* Читает зашифорванную строчку из открытого файла длинной 372 байта */
  18
+$local_f_read = fread($fd_current_file,372);
  19
+
  20
+/* Замена подстроки */
  21
+$replaced_substring = strtr($local_f_read,'EnteryouwkhRHYKNWOUTAaBbCcDdFfGgIiJjLlMmPpQqSsVvXxZz0123456789+/=','ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/');
  22
+
  23
+/* $OO00O00O0 Зашифрованный контейнер */
  24
+$crypto_container=(base64_decode($replaced_substring));
  25
+/* Исполнение зашифрованного контейнера */
  26
+/* eval($crypto_container); */
  27
+
  28
+/* Вторая часть расшифровщика */
  29
+
  30
+$new_container=ereg_replace('index.php',"'".$OOO0O0O00."'",(base64_decode(strtr(fread($O000O0O00,$OO00O0000),'EnteryouwkhRHYKNWOUTAaBbCcDdFfGgIiJjLlMmPpQqSsVvXxZz0123456789+/=','ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'))));
  31
+
  32
+echo ($new_container);
  33
+
  34
+fclose($O000O0O00);
  35
+/* eval($new_container); */
  36
+
  37
+phpinfo();
  38
+
  39
+?>
174  storage/dao-test-1.html
... ...
@@ -0,0 +1,174 @@
  1
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN">
  2
+<!-- Created by htmlize-1.36 in css mode. -->
  3
+<html><head>
  4
+<meta http-equiv="content-type" content="text/html; charset=windows-1251">
  5
+    <title>*slime-repl sbcl*</title>
  6
+    <style type="text/css">
  7
+    <!--
  8
+      body {
  9
+        color: #00ff00;
  10
+        background-color: #1f1f1f;
  11
+      }
  12
+      .slime-repl-input {
  13
+        /* slime-repl-input-face */
  14
+        font-weight: bold;
  15
+      }
  16
+      .slime-repl-inputed-output {
  17
+        /* slime-repl-inputed-output-face */
  18
+        color: #ff0000;
  19
+      }
  20
+      .slime-repl-output {
  21
+        /* slime-repl-output-face */
  22
+        color: #ffa07a;
  23
+      }
  24
+      .slime-repl-prompt {
  25
+        /* slime-repl-prompt-face */
  26
+        color: #00ffff;
  27
+      }
  28
+      .slime-repl-result {
  29
+      }
  30
+
  31
+      a {
  32
+        color: inherit;
  33
+        background-color: inherit;
  34
+        font: inherit;
  35
+        text-decoration: inherit;
  36
+      }
  37
+      a:hover {
  38
+        text-decoration: underline;
  39
+      }
  40
+    -->
  41
+    </style>
  42
+  </head>
  43
+  <body>
  44
+    <pre>; SLIME 2011-10-19
  45
+<span class="slime-repl-prompt">CL-USER&gt; </span><span class="slime-repl-input">(ql:quickload '(#:postmodern #:cl-json #:restas))
  46
+(defpackage #:test (:use #:cl #:postmodern))
  47
+         (in-package #:test)</span>
  48
+<span class="slime-repl-output">To load "postmodern":
  49
+  Load 1 ASDF system:
  50
+    postmodern
  51
+; Loading "postmodern"
  52
+.
  53
+To load "cl-json":
  54
+  Load 1 ASDF system:
  55
+    cl-json
  56
+; Loading "cl-json"
  57
+
  58
+To load "restas":
  59
+  Load 1 ASDF system:
  60
+    restas
  61
+; Loading "restas"
  62
+.......
  63
+</span><span class="slime-repl-result"><span class="slime-repl-inputed-output">#&lt;PACKAGE "TEST"&gt;</span></span><span class="slime-repl-result">
  64
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(defvar *prod-id* 0
  65
+  "Ïåðåìåííàÿ àâòîèíêðåìåíòà äëÿ product")
  66
+(defun *prod-id* ()
  67
+  "Àâòîèíêðåìåíò äëÿ product"
  68
+  (incf *prod-id*))
  69
+(defclass product ()
  70
+  ((id :col-type integer :initarg :id :accessor product-id)
  71
+   (name :col-type string :initarg :name :accessor product-name))
  72
+  (:metaclass dao-class)
  73
+  (:keys id))
  74
+(defun add-product (name)
  75
+  "Ïðîâåðêà íà äóáëèêàò â ÁÄ"
  76
+  (make-dao 'product 
  77
+            :id (*prod-id*)
  78
+            :name name))
  79
+(defvar *opname-id* 0
  80
+  "Ïåðåìåííàÿ àâòîèíêðåìåíòà äëÿ opname")
  81
+(defun *opname-id* ()
  82
+  "Àâòîèíêðåìåíò äëÿ opname"
  83
+  (incf *opname-id*))
  84
+(defclass opname ()
  85
+  ((id :col-type integer :initarg :id :accessor opnamet-id)
  86
+   (name :col-type string :initarg :name :accessor opname-name))
  87
+  (:metaclass dao-class)
  88
+  (:keys id))
  89
+(defun add-opname (name)
  90
+  "Ïðîâåðêà íà äóáëèêàò â ÁÄ"
  91
+  (make-dao 'opname 
  92
+            :id (*opname-id*)
  93
+            :name name))
  94
+(defvar *option-id* 0
  95
+  "Ïåðåìåííàÿ àâòîèíêðåìåíòà äëÿ option")
  96
+(defun *option-id* ()
  97
+  "Àâòîèíêðåìåíò äëÿ option"
  98
+  (incf *option-id*))
  99
+(defclass option ()
  100
+  ((pr-id :col-type integer :initarg :pr-id :accessor option-pr-id)
  101
+   (op-id :col-type integer :initarg :op-id :accessor option-op-id)
  102
+   (value :col-type string :initarg :value :accessor option-value))
  103
+  (:metaclass dao-class)
  104
+  (:keys pr-id op-id value))
  105
+(defun add-option (pr-name &amp;rest opt-list)
  106
+  "opt-list äîëæåí áûòü plist-îì"
  107
+  (unless (and opt-list
  108
+               (evenp (length opt-list)))
  109
+    (format t "íåïðàâèëüíûé opt-list")
  110
+    (return-from add-option))
  111
+  (let ((prod-list (car (select-dao 'product (:ilike 'name pr-name)))))
  112
+    (when (null prod-list)
  113
+      (setf prod-list (add-product pr-name)))
  114
+    (loop :for i :from 0 :upto (1- (length opt-list)) :by 2
  115
+       :do (let* ((op-key (nth i opt-list))
  116
+                  (op-val (nth (1+ i) opt-list))
  117
+                  (key-list (car (select-dao 'opname (:ilike 'name op-key)))))
  118
+             (when (null key-list)
  119
+               (setf key-list (add-opname op-key)))
  120
+             (make-dao 'option
  121
+                       :pr-id (product-id prod-list)
  122
+                       :op-id (opnamet-id key-list)
  123
+                       :value op-val)))))</span>
  124
+<span class="slime-repl-result"><span class="slime-repl-inputed-output">ADD-OPTION</span></span><span class="slime-repl-result">
  125
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(connect-toplevel "ravtadb" "ravta" "ravta1111" "localhost")</span>
  126
+<span class="slime-repl-result">; No value</span>
  127
+<span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(execute (dao-table-definition 'product))</span>
  128
+<span class="slime-repl-output">WARNING:
  129
+   Postgres warning: CREATE TABLE / PRIMARY KEY will create implicit index "product_pkey" for table "product"
  130
+</span><span class="slime-repl-result"><span class="slime-repl-inputed-output">0</span></span><span class="slime-repl-result">
  131
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(execute (dao-table-definition 'opname))</span>
  132
+<span class="slime-repl-output">WARNING:
  133
+   Postgres warning: CREATE TABLE / PRIMARY KEY will create implicit index "opname_pkey" for table "opname"
  134
+</span><span class="slime-repl-result"><span class="slime-repl-inputed-output">0</span></span><span class="slime-repl-result">
  135
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(execute (dao-table-definition 'option))</span>
  136
+<span class="slime-repl-output">WARNING:
  137
+   Postgres warning: CREATE TABLE / PRIMARY KEY will create implicit index "option_pkey" for table "option"
  138
+</span><span class="slime-repl-result"><span class="slime-repl-inputed-output">0</span></span><span class="slime-repl-result">
  139
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(query "ALTER TABLE product ADD CONSTRAINT uq_p_name UNIQUE (name)")</span>
  140
+<span class="slime-repl-output">WARNING:
  141
+   Postgres warning: ALTER TABLE / ADD UNIQUE will create implicit index "uq_p_name" for table "product"
  142
+</span><span class="slime-repl-result"><span class="slime-repl-inputed-output">NIL</span></span><span class="slime-repl-result">
  143
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(query "ALTER TABLE product ADD CHECK (name &lt;&gt; '')")</span>
  144
+<span class="slime-repl-result"><span class="slime-repl-inputed-output">NIL</span></span><span class="slime-repl-result">
  145
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(query "ALTER TABLE opname ADD CONSTRAINT uq_o_name UNIQUE (name)")
  146
+(query "ALTER TABLE opname ADD CHECK (name &lt;&gt; '')")
  147
+(query "ALTER TABLE option ADD FOREIGN KEY (pr_id) REFERENCES product(id)")</span>
  148
+<span class="slime-repl-output">WARNING:
  149
+   Postgres warning: ALTER TABLE / ADD UNIQUE will create implicit index "uq_o_name" for table "opname"
  150
+</span><span class="slime-repl-result"><span class="slime-repl-inputed-output">NIL</span></span><span class="slime-repl-result">
  151
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(query "ALTER TABLE option ADD FOREIGN KEY (op_id) REFERENCES opname(id)")</span>
  152
+<span class="slime-repl-result"><span class="slime-repl-inputed-output">NIL</span></span><span class="slime-repl-result">
  153
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(add-product "oil")</span>
  154
+<span class="slime-repl-result"><span class="slime-repl-inputed-output">#&lt;PRODUCT {10041B0083}&gt;</span></span><span class="slime-repl-result">
  155
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(add-product "ìàñëî A")
  156
+(add-product "ìàñëî B")
  157
+(add-opname "îáú¸ì")
  158
+(add-opname "âÿçêîñòü")</span>
  159
+<span class="slime-repl-result"><span class="slime-repl-inputed-output">#&lt;OPNAME {10041F5C53}&gt;</span></span><span class="slime-repl-result">
  160
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(add-option "oil" "îáú¸ì" "3ë." "îáú¸ì" "4ë.")</span>
  161
+<span class="slime-repl-result"><span class="slime-repl-inputed-output">NIL</span></span><span class="slime-repl-result">
  162
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(add-option "oil" "îáú¸ì" "3,5ë." "îáú¸ì" "4,5ë.")</span>
  163
+<span class="slime-repl-result"><span class="slime-repl-inputed-output">NIL</span></span><span class="slime-repl-result">
  164
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(add-option "ìàñëî U" "âåñ" "7,5ã")</span>
  165
+<span class="slime-repl-result"><span class="slime-repl-inputed-output">NIL</span></span><span class="slime-repl-result">
  166
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(add-option "ìàñëî U" "âåñ" "7,5ã" "gjh")</span>
  167
+<span class="slime-repl-output">íåïðàâèëüíûé opt-list
  168
+</span><span class="slime-repl-result"><span class="slime-repl-inputed-output">NIL</span></span><span class="slime-repl-result">
  169
+</span><span class="slime-repl-prompt">TEST&gt; </span><span class="slime-repl-input">(add-option "oil" "îáú¸ì" "3,5ë." "îáú¸ì" "4,5ë.")</span>
  170
+; Evaluation aborted on #&lt;CL-POSTGRES-ERROR:UNIQUE-VIOLATION {100459A933}&gt;.
  171
+<span class="slime-repl-prompt">TEST&gt; </span></pre>
  172
+  
  173
+
  174
+</body></html>
46  storage/jsonq.js
... ...
@@ -0,0 +1,46 @@
  1
+[
  2
+{
  3
+ "attr":
  4
+  {
  5
+    "id":"tag_1",
  6
+    "rel":"tag"
  7
+  },
  8
+  "data":"\u0421\u043f\u0435\u0446\u0438\u0430\u043b\u044c\u043d\u043e\u0435 \u043f\u0440\u0435\u0434\u043b\u043e\u0436\u0435\u043d\u0438\u0435",
  9
+  "state":"closed"
  10
+},
  11
+{
  12
+  "attr":
  13
+  {
  14
+    "id":"menu_category_1",
  15
+    "rel":"menu"
  16
+  },
  17
+  "data":"\u041e\u0441\u043d\u043e\u0432\u043d\u043e\u0435 \u043c\u0435\u043d\u044e",
  18
+  "state":"closed"
  19
+},
  20
+  "attr":
  21
+  {
  22
+    "id":"menu_category_2",
  23
+    "rel":"bar"
  24
+  },
  25
+  "data":"\u0411\u0430\u0440",
  26
+  "state":"closed"
  27
+},
  28
+{
  29
+  "attr":
  30
+  {
  31
+    "id":"tag_2",
  32
+    "rel":"tag"
  33
+  },
  34
+  "data":"\u0417\u0430\u0432\u0442\u0440\u0430\u043a",
  35
+  "state":"closed"
  36
+},
  37
+{
  38
+  "attr":
  39
+  {
  40
+  "id":"tag_3",
  41
+  "rel":"tag"
  42
+  },
  43
+  "data":"\u041b\u0430\u043d\u0447","state":"closed"
  44
+},
  45
+{
  46
+  "attr":{"id":"tag_4","rel":"tag"},"data":"\u0414\u0435\u0442\u0441\u043a\u043e\u0435 \u043c\u0435\u043d\u044e","state":"closed"},{"attr":{"id":"tag_5","rel":"tag"},"data":"\u0411\u0430\u043d\u043a\u0435\u0442\u043d\u043e\u0435 \u043c\u0435\u043d\u044e","state":"closed"}]
349  storage/table.lisp
... ...
@@ -0,0 +1,349 @@
  1
+;;;; для работы с БД
  2
+
  3
+(defclass dao-class (standard-class)
  4
+  ((direct-keys :initarg :keys :initform nil :reader direct-keys)
  5
+   (effective-keys :reader dao-keys)
  6
+   (table-name)
  7
+   (column-map :reader dao-column-map))
  8
+  (:documentation "Metaclass for database-access-object classes."))
  9
+
  10
+(defmethod dao-keys :before ((class dao-class))
  11
+  (unless (class-finalized-p class)
  12
+    (finalize-inheritance class)))
  13
+
  14
+(defmethod validate-superclass ((class dao-class) (super-class standard-class))
  15
+  t)
  16
+
  17
+(defmethod dao-keys ((class-name symbol))
  18
+  (dao-keys (find-class class-name)))
  19
+
  20
+(defmethod dao-keys (dao)
  21
+  (mapcar #'(lambda (slot)
  22
+              (slot-value dao slot))
  23
+          (dao-keys (class-of dao))))
  24
+
  25
+(defun dao-column-slots (class)
  26
+  "Enumerate the slots in a class that refer to table rows."
  27
+  (mapcar 'slot-column
  28
+          (remove-if-not (lambda (x) (typep x 'effective-column-slot))
  29
+                         (class-slots class))))
  30
+(defun dao-column-fields (class)
  31
+  (mapcar 'slot-definition-name (dao-column-slots class)))
  32
+
  33
+(defun dao-table-name (class)
  34
+  (when (symbolp class)
  35
+    (setf class (find-class class)))
  36
+  (if (slot-boundp class 'table-name)
  37
+      (slot-value class 'table-name)
  38
+      (class-name class)))
  39
+
  40
+(defmethod shared-initialize :before ((class dao-class) slot-names
  41
+                                      &key table-name &allow-other-keys)
  42
+  (declare (ignore slot-names))
  43
+  (setf (slot-value class 'direct-keys) nil)
  44
+  (if table-name
  45
+      (setf (slot-value class 'table-name)
  46
+            (if (symbolp (car table-name)) (car table-name) (intern (car table-name))))
  47
+      (slot-makunbound class 'table-name)))
  48
+
  49
+(defun dao-superclasses (class)
  50
+  "Build a list of superclasses of a given class that are DAO
  51
+  classes."
  52
+  (let ((found ()))
  53
+    (labels ((explore (class)
  54
+               (when (typep class 'dao-class)
  55
+                 (pushnew class found))
  56
+               (mapc #'explore (class-direct-superclasses class))))
  57
+      (explore class)
  58
+      found)))
  59
+
  60
+(defmethod finalize-inheritance :after ((class dao-class))
  61
+  "Building a row reader and a set of methods can only be done after
  62
+  inheritance has been finalised."
  63
+  ;; The effective set of keys of a class is the union of its keys and
  64
+  ;; the keys of all its superclasses.
  65
+  (setf (slot-value class 'effective-keys)
  66
+        (reduce 'union (mapcar 'direct-keys (dao-superclasses class))))
  67
+  (unless (every (lambda (x) (member x (dao-column-fields class))) (dao-keys class))
  68
+    (error "Class ~A has a key that is not also a slot." (class-name class)))
  69
+  (build-dao-methods class))
  70
+
  71
+
  72
+(defclass direct-column-slot (standard-direct-slot-definition)
  73
+  ((col-type :initarg :col-type :reader column-type)
  74
+   (col-default :initarg :col-default :reader column-default)
  75
+   (ghost :initform nil :initarg :ghost :reader ghost)
  76
+   (sql-name :reader slot-sql-name))
  77
+  (:documentation "Type of slots that refer to database columns."))
  78
+
  79
+(defmethod shared-initialize :after ((slot direct-column-slot) slot-names
  80
+                                     &key col-type col-default &allow-other-keys)
  81
+  (declare (ignore slot-names))
  82
+  (setf (slot-value slot 'sql-name) (to-sql-name (slot-definition-name slot) nil))
  83
+  ;; The default for nullable columns defaults to :null.
  84
+  (when (and (null col-default) (consp col-type) (eq (car col-type) 'or)
  85
+             (member 'db-null col-type) (= (length col-type) 3))
  86
+    (setf (slot-value slot 'col-default) :null)))
  87
+
  88
+(defmethod direct-slot-definition-class ((class dao-class) &key column col-type &allow-other-keys)
  89
+  "Slots that have a :col-type option are column-slots."
  90
+  (if (or column col-type)
  91
+      (find-class 'direct-column-slot)
  92
+      (call-next-method)))
  93
+
  94
+(defparameter *direct-column-slot* nil
  95
+  "This is used to communicate the fact that a slot is a column to
  96
+  effective-slot-definition-class.")
  97
+
  98
+(defclass effective-column-slot (standard-effective-slot-definition)
  99
+  ((direct-slot :initform *direct-column-slot* :reader slot-column)))
  100
+
  101
+(defmethod compute-effective-slot-definition ((class dao-class) name direct-slot-definitions)
  102
+  (declare (ignore name))
  103
+  (flet ((is-column (slot) (typep slot 'direct-column-slot)))
  104
+    (let ((*direct-column-slot* (find-if #'is-column direct-slot-definitions)))
  105
+      #+(or) ;; Things seem to work without this check. Removed for now.
  106
+      (when (and *direct-column-slot*
  107
+                 (not (every #'is-column direct-slot-definitions)))
  108
+        (error "Slot ~a in class ~a is both a column slot and a regular slot." name class))
  109
+      (call-next-method))))
  110
+
  111
+(defmethod effective-slot-definition-class ((class dao-class) &rest initargs)
  112
+  (declare (ignore initargs))
  113
+  (if *direct-column-slot*
  114
+      (find-class 'effective-column-slot)
  115
+      (call-next-method)))
  116
+
  117
+(defgeneric dao-exists-p (dao)
  118
+  (:documentation "Return a boolean indicating whether the given dao
  119
+  exists in the database."))
  120
+(defgeneric insert-dao (dao)
  121
+  (:documentation "Insert the given object into the database."))
  122
+(defgeneric update-dao (dao)
  123
+  (:documentation "Update the object's representation in the database
  124
+  with the values in the given instance."))
  125
+(defgeneric delete-dao (dao)
  126
+  (:documentation "Delete the given dao from the database."))
  127
+(defgeneric get-dao (type &rest args)
  128
+  (:method ((class-name symbol) &rest args)
  129
+    (let ((class (find-class class-name)))
  130
+      (if (class-finalized-p class)
  131
+          (error "Class ~a has no key slots." (class-name class))
  132
+          (finalize-inheritance class))
  133
+      (apply 'get-dao class-name args)))
  134
+  (:documentation "Get the object corresponding to the given primary
  135
+  key, or return nil if it does not exist."))
  136
+(defgeneric make-dao (type &rest args &key &allow-other-keys)
  137
+  (:method ((class-name symbol) &rest args &key &allow-other-keys)
  138
+    (let ((class (find-class class-name)))
  139
+      (apply 'make-dao class args)))
  140
+  (:method ((class dao-class) &rest args &key &allow-other-keys)
  141
+    (unless (class-finalized-p class)
  142
+      (finalize-inheritance class))
  143
+    (let ((instance (apply #'make-instance class args)))
  144
+      (insert-dao instance)))
  145
+  (:documentation "Make the instance of the given class and insert it into the database"))
  146
+
  147
+(defmacro define-dao-finalization (((dao-name class) &rest keyword-args) &body body)
  148
+  (let ((args-name (gensym)))
  149
+    `(defmethod make-dao :around ((class (eql ',class)) 
  150
+				  &rest ,args-name
  151
+				  &key ,@keyword-args &allow-other-keys)
  152
+       (declare (ignorable ,args-name))
  153
+       (let ((,dao-name (call-next-method)))
  154
+	 ,@body
  155
+	 (update-dao ,dao-name)))))
  156
+
  157
+(defgeneric fetch-defaults (object)
  158
+  (:documentation "Used to fetch the default values of an object on
  159
+  creation."))
  160
+
  161
+(defun %eval (code)
  162
+  (funcall (compile nil `(lambda () ,code))))
  163
+
  164
+(defun build-dao-methods (class)
  165
+  "Synthesise a number of methods for a newly defined DAO class.
  166
+\(Done this way because some of them are not defined in every
  167
+situation, and each of them needs to close over some pre-computed
  168
+values.)"
  169
+
  170
+  (setf (slot-value class 'column-map)
  171
+        (mapcar (lambda (s) (cons (slot-sql-name s) (slot-definition-name s))) (dao-column-slots class)))
  172
+
  173
+  (%eval
  174
+    `(let* ((fields (dao-column-fields ,class))
  175
+            (key-fields (dao-keys ,class))
  176
+            (ghost-slots (remove-if-not 'ghost (dao-column-slots ,class)))
  177
+            (ghost-fields (mapcar 'slot-definition-name ghost-slots))
  178
+            (value-fields (remove-if (lambda (x) (or (member x key-fields) (member x ghost-fields))) fields))
  179
+            (table-name (dao-table-name ,class)))
  180
+       (flet ((test-fields (fields)
  181
+                `(:and ,@(loop :for field :in fields :collect (list := field '$$))))
  182
+              (set-fields (fields)
  183
+                (loop :for field :in fields :append (list field '$$)))
  184
+              (slot-values (object &rest slots)
  185
+                (loop :for slot :in (apply 'append slots) :collect (slot-value object slot))))
  186
+
  187
+         ;; When there is no primary key, a lot of methods make no sense.
  188
+         (when key-fields
  189
+           (let ((tmpl (sql-template `(:select (:exists (:select t :from ,table-name
  190
+                                                                 :where ,(test-fields key-fields)))))))
  191
+             (defmethod dao-exists-p ((object ,class))
  192
+               (and (every (lambda (s) (slot-boundp object s)) key-fields)
  193
+                    (query (apply tmpl (slot-values object key-fields)) :single))))
  194
+  
  195
+           ;; When all values are primary keys, updating makes no sense.
  196
+           (when value-fields
  197
+             (let ((tmpl (sql-template `(:update ,table-name :set ,@(set-fields value-fields)
  198
+                                                 :where ,(test-fields key-fields)))))
  199
+               (defmethod update-dao ((object ,class))
  200
+                 (when (zerop (execute (apply tmpl (slot-values object value-fields key-fields))))
  201
+                   (error "Updated row does not exist."))
  202
+                 object)))
  203
+  
  204
+           (let ((tmpl (sql-template `(:delete-from ,table-name :where ,(test-fields key-fields)))))
  205
+             (defmethod delete-dao ((object ,class))
  206
+               (execute (apply tmpl (slot-values object key-fields)))))
  207
+  
  208
+           (let ((tmpl (sql-template `(:select * :from ,table-name :where ,(test-fields key-fields)))))
  209
+             (defmethod get-dao ((type (eql (class-name ,class))) &rest keys)
  210
+               (car (exec-query *database* (apply tmpl keys) (dao-row-reader ,class))))))
  211
+
  212
+         (defmethod insert-dao ((object ,class))
  213
+           (let (bound unbound)
  214
+             (loop :for field :in fields
  215
+                :do (if (slot-boundp object field)
  216
+                        (push field bound)
  217
+                        (push field unbound)))
  218
+
  219
+             (let* ((values (mapcan (lambda (x) (list x (slot-value object x)))
  220
+                                    (remove-if (lambda (x) (member x ghost-fields)) bound) ))
  221
+                    (returned (query (sql-compile `(:insert-into ,table-name
  222
+                                                                 :set ,@values
  223
+                                                                 ,@(when unbound (cons :returning unbound))))
  224
+                                     :row)))
  225
+               (when unbound
  226
+                 (loop :for value :in returned
  227
+                    :for field :in unbound
  228
+                    :do (setf (slot-value object field) value)))))
  229
+           object)
  230
+
  231
+
  232
+         (let* ((defaulted-slots (remove-if-not (lambda (x) (slot-boundp x 'col-default))
  233
+                                                (dao-column-slots ,class)))
  234
+                (defaulted-names (mapcar 'slot-definition-name defaulted-slots))
  235
+                (default-values (mapcar 'column-default defaulted-slots)))
  236
+           (if defaulted-slots
  237
+               (defmethod fetch-defaults ((object ,class))
  238
+                 (let (names defaults)
  239
+                   ;; Gather unbound slots and their default expressions.
  240
+                   (loop :for slot-name :in defaulted-names
  241
+                      :for default :in default-values
  242
+                      :do (unless (slot-boundp object slot-name)
  243
+                            (push slot-name names)
  244
+                            (push default defaults)))
  245
+                   ;; If there are any unbound, defaulted slots, fetch their content.
  246
+                   (when names
  247
+                     (loop :for value :in (query (sql-compile (cons :select defaults)) :list)
  248
+                        :for slot-name :in names
  249
+                        :do (setf (slot-value object slot-name) value)))))
  250
+               (defmethod fetch-defaults ((object ,class))
  251
+                 nil)))
  252
+
  253
+         (defmethod shared-initialize :after ((object ,class) slot-names
  254
+                                              &key (fetch-defaults nil) &allow-other-keys)
  255
+           (declare (ignore slot-names))
  256
+           (when fetch-defaults
  257
+             (fetch-defaults object)))))))
  258
+
  259
+(defparameter *custom-column-writers* nil
  260
+  "A hook for locally overriding/adding behaviour to DAO row readers.
  261
+Should be an alist mapping strings (column names) to symbols or
  262
+functions. Symbols are interpreted as slot names that values should be
  263
+written to, functions are called with the new object and the value as
  264
+arguments.")
  265
+
  266
+(defmacro with-column-writers ((&rest defs) &body body)
  267
+  `(let ((*custom-column-writers* (append (list ,@(loop :for (field writer) :on defs :by #'cddr
  268
+                                                        :collect `(cons (to-sql-name ,field) ,writer)))
  269
+                                          *custom-column-writers*)))
  270
+    ,@body))
  271
+
  272
+(defparameter *ignore-unknown-columns* nil)
  273
+
  274
+(defun dao-row-reader (class)
  275
+  "Defines a row-reader for objects of a given class."
  276
+  (row-reader (query-fields)
  277
+    (let ((column-map (append *custom-column-writers* (dao-column-map class))))
  278
+      (loop :while (next-row)
  279
+            :collect (let ((instance (allocate-instance class)))
  280
+                       (loop :for field :across query-fields
  281
+                             :for writer := (cdr (assoc (field-name field) column-map :test #'string=))
  282
+                             :do (etypecase writer
  283
+                                   (null (if *ignore-unknown-columns*
  284
+                                             (next-field field)
  285
+                                             (error "No slot named ~a in class ~a. DAO out of sync with table, or incorrect query used."
  286
+                                                    (field-name field) (class-name class))))
  287
+                                   (symbol (setf (slot-value instance writer) (next-field field)))
  288
+                                   (function (funcall writer instance (next-field field)))))
  289
+                       (initialize-instance instance)
  290
+                       instance)))))
  291
+
  292
+(defun save-dao (dao)
  293
+  "Try to insert the content of a DAO. If this leads to a unique key
  294
+violation, update it instead."
  295
+  (handler-case (progn (insert-dao dao) t)
  296
+    (cl-postgres-error:unique-violation ()
  297
+      (update-dao dao)
  298
+      nil)))
  299
+
  300
+(defun save-dao/transaction (dao)
  301
+  (handler-case (with-savepoint save-dao/transaction (insert-dao dao) t)
  302
+    (cl-postgres-error:unique-violation ()
  303
+      (update-dao dao)
  304
+      nil)))
  305
+
  306
+(defun query-dao% (type query &rest args)
  307
+  (let ((class (find-class type)))
  308
+    (unless (class-finalized-p class)
  309
+      (finalize-inheritance class))
  310
+    (if args
  311
+	(progn
  312
+	  (prepare-query *database* "" query)
  313
+	  (exec-prepared *database* "" args (dao-row-reader class)))
  314
+	(exec-query *database* query (dao-row-reader class)))))
  315
+
  316
+(defmacro query-dao (type query &rest args)
  317
+  "Execute a query and return the result as daos of the given type.
  318
+The fields returned by the query must match the slots of the dao, both
  319
+by type and by name."
  320
+  `(query-dao% ,type ,(real-query query) ,@args))
  321
+
  322
+(defmacro select-dao (type &optional (test t) &rest ordering)
  323
+  "Select daos for the rows in its table for which the given test
  324
+holds, order them by the given criteria."
  325
+  (flet ((check-string (x)
  326
+           (if (stringp x) `(:raw ,x) x)))
  327
+    (let* ((type-name (gensym))
  328
+           (query `(:select '* :from (dao-table-name (find-class ,type-name))
  329
+                    :where ,(check-string test))))
  330
+      (when ordering
  331
+        (setf query `(:order-by ,query ,@(mapcar #'check-string ordering))))
  332
+      `(let ((,type-name ,type))
  333
+         (query-dao% ,type-name (sql ,query))))))
  334
+
  335
+(defun dao-table-definition (table)
  336
+  "Generate the appropriate CREATE TABLE query for this class."
  337
+  (unless (typep table 'dao-class)
  338
+    (setf table (find-class table)))
  339
+  (unless (class-finalized-p table)
  340
+    (finalize-inheritance table))
  341
+  (sql-compile
  342
+   `(:create-table ,(dao-table-name table)
  343
+                   ,(loop :for slot :in (dao-column-slots table)
  344
+                          :unless (ghost slot)
  345
+                          :collect `(,(slot-definition-name slot) :type ,(column-type slot)
  346
+                                     ,@(when (slot-boundp slot 'col-default)
  347
+                                             `(:default ,(column-default slot)))))
  348
+                   ,@(when (dao-keys table)
  349
+                       `((:primary-key ,@(dao-keys table)))))))

No commit comments for this range

Something went wrong with that request. Please try again.