extra/persistency/persistency.factor

   1 USING: accessors arrays byte-arrays calendar classes
   2 classes.tuple classes.tuple.parser combinators db db.queries
   3 db.tuples db.types kernel math nmake parser sequences strings
   4 strings.parser unicode urls words ;
   5 IN: persistency
   6
   7 TUPLE: persistent id ;
   8
   9 : add-types ( table -- table' )
  10     [
  11         dup array? [
  12             [ first dup >upper ] [ second ] bi 3array
  13         ] [
  14             dup >upper FACTOR-BLOB 3array
  15         ] if
  16     ] map { "id" "ID" +db-assigned-id+ } prefix ;
  17
  18 : remove-types ( table -- table' )
  19     [ dup array? [ first ] when ] map ;
  20
  21 SYNTAX: STORED-TUPLE:
  22     parse-tuple-definition [ drop persistent ] dip
  23     [ remove-types define-tuple-class ]
  24     [ nip [ dup name>> >upper ] [ add-types ] bi* define-persistent ] 3bi ;
  25
  26 : define-db ( database class -- )
  27     swap [ [ ensure-table ] with-db ] [ "database" set-word-prop ] 2bi ;
  28
  29 : query>tuple ( tuple/query -- tuple )
  30     dup query? [ tuple>> ] when ;
  31
  32 : w/db ( query quot -- )
  33     [ dup query>tuple class-of "database" word-prop ] dip with-db ; inline
  34
  35 : get-tuples ( query -- tuples ) [ select-tuples ] w/db ;
  36 : get-tuple ( query -- tuple ) [ select-tuple ] w/db ;
  37 : store-tuple ( tuple -- ) [ insert-tuple ] w/db ;
  38 : modify-tuple ( tuple -- ) [ update-tuple ] w/db ;
  39 : remove-tuples ( tuple -- ) [ delete-tuples ] w/db ;
  40
  41 TUPLE: pattern value ;
  42 C: <pattern> pattern
  43 SYNTAX: %" parse-string <pattern> suffix! ;
  44 M: pattern where value>> over column-name>> 0% " LIKE " 0% bind# ;