basis/db/tuples/tuples.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs classes db kernel namespaces
   4 classes.tuple words sequences slots math accessors
   5 math.parser io prettyprint db.types continuations
   6 destructors mirrors sets db.types db.private ;
   7 IN: db.tuples
   8
   9 HOOK: create-sql-statement db-connection ( class -- object )
  10 HOOK: drop-sql-statement db-connection ( class -- object )
  11
  12 HOOK: <insert-db-assigned-statement> db-connection ( class -- object )
  13 HOOK: <insert-user-assigned-statement> db-connection ( class -- object )
  14 HOOK: <update-tuple-statement> db-connection ( class -- object )
  15 HOOK: <delete-tuples-statement> db-connection ( tuple class -- object )
  16 HOOK: <select-by-slots-statement> db-connection ( tuple class -- tuple )
  17 HOOK: <count-statement> db-connection ( query -- statement )
  18 HOOK: query>statement db-connection ( query -- statement )
  19 HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
  20
  21 <PRIVATE
  22
  23 SYMBOL: sql-counter
  24
  25 : next-sql-counter ( -- str )
  26     sql-counter [ inc ] [ get ] bi number>string ;
  27
  28 GENERIC: eval-generator ( singleton -- object )
  29
  30 : resulting-tuple ( exemplar-tuple row out-params -- tuple )
  31     rot class new [
  32         [ [ slot-name>> ] dip set-slot-named ] curry 2each
  33     ] keep ;
  34
  35 : query-tuples ( exemplar-tuple statement -- seq )
  36     [ out-params>> ] keep query-results [
  37         [ sql-row-typed swap resulting-tuple ] with with query-map
  38     ] with-disposal ;
  39
  40 : query-modify-tuple ( tuple statement -- )
  41     [ query-results [ sql-row-typed ] with-disposal ] keep
  42     out-params>> rot [
  43         [ slot-name>> ] dip set-slot-named
  44     ] curry 2each ;
  45
  46 : with-disposals ( object quotation -- )
  47     over sequence? [
  48         [ with-disposal ] curry each
  49     ] [
  50         with-disposal
  51     ] if ; inline
  52
  53 : insert-db-assigned-statement ( tuple -- )
  54     dup class
  55     db-connection get insert-statements>>
  56     [ <insert-db-assigned-statement> ] cache
  57     [ bind-tuple ] 2keep insert-tuple-set-key ;
  58
  59 : insert-user-assigned-statement ( tuple -- )
  60     dup class
  61     db-connection get insert-statements>>
  62     [ <insert-user-assigned-statement> ] cache
  63     [ bind-tuple ] keep execute-statement ;
  64
  65 : do-select ( exemplar-tuple statement -- tuples )
  66     [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
  67
  68 : do-count ( exemplar-tuple statement -- tuples )
  69     [ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
  70
  71 PRIVATE>
  72
  73 ! High level
  74 ERROR: no-slots-named class seq ;
  75 : check-columns ( class columns -- )
  76     tuck
  77     [ [ first ] map ]
  78     [ all-slots [ name>> ] map ] bi* diff
  79     [ drop ] [ no-slots-named ] if-empty ;
  80
  81 : define-persistent ( class table columns -- )
  82     pick dupd
  83     check-columns
  84     [ dupd "db-table" set-word-prop dup ] dip
  85     [ relation? ] partition swapd
  86     dupd [ spec>tuple ] with map
  87     "db-columns" set-word-prop
  88     "db-relations" set-word-prop ;
  89
  90 TUPLE: query tuple group order offset limit ;
  91
  92 : <query> ( -- query ) \ query new ;
  93
  94 GENERIC: >query ( object -- query )
  95
  96 M: query >query clone ;
  97
  98 M: tuple >query <query> swap >>tuple ;
  99
 100 : create-table ( class -- )
 101     create-sql-statement [ execute-statement ] with-disposals ;
 102
 103 : drop-table ( class -- )
 104     drop-sql-statement [ execute-statement ] with-disposals ;
 105
 106 : recreate-table ( class -- )
 107     [
 108         [ drop-sql-statement [ execute-statement ] with-disposals
 109         ] curry ignore-errors
 110     ] [ create-table ] bi ;
 111
 112 : ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
 113
 114 : ensure-tables ( classes -- ) [ ensure-table ] each ;
 115
 116 : insert-tuple ( tuple -- )
 117     dup class db-columns find-primary-key db-assigned-id-spec?
 118     [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
 119
 120 : update-tuple ( tuple -- )
 121     dup class
 122     db-connection get update-statements>> [ <update-tuple-statement> ] cache
 123     [ bind-tuple ] keep execute-statement ;
 124
 125 : delete-tuples ( tuple -- )
 126     dup dup class <delete-tuples-statement> [
 127         [ bind-tuple ] keep execute-statement
 128     ] with-disposal ;
 129
 130 : select-tuples ( query/tuple -- tuples )
 131     >query [ tuple>> ] [ query>statement ] bi do-select ;
 132
 133 : select-tuple ( query/tuple -- tuple/f )
 134     >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
 135     [ f ] [ first ] if-empty ;
 136
 137 : count-tuples ( query/tuple -- n )
 138     >query [ tuple>> ] [ <count-statement> ] bi do-count
 139     dup length 1 =
 140     [ first first string>number ] [ [ first string>number ] map ] if ;