Changeset 14766 in project


Ignore:
Timestamp:
05/24/09 17:36:13 (10 years ago)
Author:
sjamaan
Message:

Change interface so it's more sql-de-lite-like, because it's more flexible (now one can map high-level style through a result even while obtaining other data from the same result)

Location:
release/4/postgresql/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/postgresql/trunk/postgresql.scm

    r14765 r14766  
    2727  connect reset-connection disconnect connection?
    2828 
    29   exec-simple-queries exec-query
     29  simple-queries query query*
    3030 
    3131  result? clear-result! row-count column-count
     
    3838  escape-string escape-bytea unescape-bytea
    3939 
    40   query-fold query-fold* query-fold-right query-fold-right*
    41   query-for-each query-for-each* query-map query-map*)
     40  row-fold row-fold* row-fold-right row-fold-right*
     41  row-for-each row-for-each* row-map row-map*)
    4242
    4343(import chicken scheme foreign)
     
    198198    (pg-connection-type-parsers-set! conn type-parsers)
    199199    (unless (null? type-parsers)   ; empty IN () clause is not allowed
    200       (query-for-each*
     200      (row-for-each*
    201201       (lambda (oid typname)
    202202         (and-let* ((procedure (assoc typname type-parsers)))
    203203           (hash-table-set! ht (string->number oid) (cdr procedure))))
    204        conn
    205        (conc "SELECT oid, typname FROM pg_type WHERE typname IN "
    206              "('" (string-intersperse
    207                    (map (lambda (p) (escape-string conn (car p)))
    208                         type-parsers) "', '") "')")))))
     204       (query*
     205        conn
     206        (conc "SELECT oid, typname FROM pg_type WHERE typname IN "
     207              "('" (string-intersperse
     208                    (map (lambda (p) (escape-string conn (car p)))
     209                         type-parsers) "', '") "')"))))))
    209210
    210211(define (update-type-unparsers! conn new-type-unparsers)
     
    533534          (reverse! results)))))
    534535
    535 (define (exec-simple-queries conn query)
     536(define (simple-queries conn query)
    536537  (if ((foreign-lambda bool PQsendQuery pgconn* (const c-string))
    537538       (pg-connection-ptr conn) query)
     
    542543                        conn query)))
    543544
    544 (define (exec-query conn query #!optional (params '()) #!key (format 'text) raw)
     545(define (query conn query . params)
     546  (query* conn query params))
     547
     548(define (query* conn query #!optional (params '()) #!key (format 'text) raw)
    545549  (let* ((unparsers (pg-connection-type-unparsers conn))
    546550         (unparse (lambda (x)
     
    558562                          (not (sql-null? obj)))
    559563                 (postgresql-error
    560                   'exec-query
     564                  'query*
    561565                  (sprintf "Param value is not a string, sql-null or blob: ~S" p)
    562566                  conn query params format))
     
    610614                   (length params) params (symbol->format format))
    611615       (car (collect-results conn)) ;; assumed to always return one result...
    612        (postgresql-error 'exec-query
     616       (postgresql-error 'query*
    613617                         (conc "Unable to send query to server. "
    614618                               (PQerrorMessage (pg-connection-ptr conn)))
     
    682686;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    683687
    684 (define (%query-fold kons knil conn query params)
    685   (let* ((result (exec-query conn query params))
    686          (rows (row-count result)))
     688(define (row-fold kons knil result)
     689  (let ((rows (row-count result)))
    687690    (let loop ((seed knil)
    688691               (row 0))
     
    690693          seed
    691694          (loop (kons (row-values result row) seed) (add1 row))))))
    692 
    693 (define (%query-fold-right kons knil conn query params)
    694   (let* ((result (exec-query conn query params))
    695          (rows (row-count result)))
     695(define (row-fold* kons knil result)
     696  (row-fold (lambda (values seed)
     697              (apply kons (append values (list seed)))) knil result))
     698
     699(define (row-fold-right kons knil result)
     700  (let ((rows (row-count result)))
    696701    (let loop ((seed knil)
    697702               (row 0))
     
    699704          seed
    700705          (kons (row-values result row) (loop seed (add1 row)))))))
    701 
    702 (define (query-fold kons knil conn query . params)
    703   (%query-fold kons knil conn query params))
    704 (define (query-fold* kons knil conn query . params)
    705   (%query-fold (lambda (values seed) (apply kons (append values (list seed))))
    706                knil conn query params))
    707 (define (query-fold-right kons knil conn query . params)
    708   (%query-fold-right kons knil conn query params))
    709 (define (query-fold-right* kons knil conn query . params)
    710   (%query-fold-right (lambda (val seed) (apply kons (append val (list seed))))
    711                      knil conn query params))
    712 
    713 (define (query-for-each proc conn query . params)
    714   (%query-fold (lambda (values seed) (proc values)) #f conn query params)
     706(define (row-fold-right* kons knil result)
     707  (row-fold-right (lambda (val seed)
     708                    (apply kons (append val (list seed)))) knil result))
     709
     710(define (row-for-each proc result)
     711  (row-fold (lambda (values seed) (proc values)) #f result)
    715712  (void))
    716 
    717 (define (query-for-each* proc conn query . params)
    718   (%query-fold (lambda (values seed) (apply proc values)) #f conn query params)
     713(define (row-for-each* proc result)
     714  (row-fold (lambda (values seed) (apply proc values)) #f result)
    719715  (void))
    720716
     
    722718;; undefined.  We make good use of that by traversing the resultset from
    723719;; the end back to the beginning, thereby avoiding a reverse! on the result.
    724 (define (%query-map proc conn query params)
    725   (let ((result (exec-query conn query params)))
    726     (let loop ((lst '())
    727                (row (row-count result)))
    728       (if (= row 0)
    729           lst
    730           (loop (cons (proc (row-values result (sub1 row))) lst) (sub1 row))))))
    731 (define (query-map proc conn query . params)
    732   (%query-map proc conn query params))
    733 
    734 (define (query-map* proc conn query . params)
    735   (%query-map (lambda (values) (apply proc values)) conn query params))
     720(define (row-map proc result)
     721  (let loop ((lst '())
     722             (row (row-count result)))
     723    (if (= row 0)
     724        lst
     725        (loop (cons (proc (row-values result (sub1 row))) lst) (sub1 row)))))
     726(define (row-map* proc result)
     727  (row-map (lambda (values) (apply proc values)) result))
    736728
    737729)
  • release/4/postgresql/trunk/tests/run.scm

    r14765 r14766  
    3232(test-group "low-level interface"
    3333  (test-assert "query returns result"
    34                (result? (exec-query conn "SELECT 1")))
     34               (result? (query conn "SELECT 1")))
    3535  (test "simple queries return several results"
    3636        2
    37         (length (exec-simple-queries conn "SELECT 10; SELECT 100")))
     37        (length (simple-queries conn "SELECT 10; SELECT 100")))
    3838  (test "Correct row count"
    3939        2
    40         (row-count (exec-query conn "SELECT 1 UNION SELECT 2")))
     40        (row-count (query conn "SELECT 1 UNION SELECT 2")))
    4141  (test "Correct column count"
    4242        4
    43         (column-count (exec-query conn "SELECT 1, 2, 3, 4")))
     43        (column-count (query conn "SELECT 1, 2, 3, 4")))
    4444  (test "Correct column name"
    4545        'one
    4646        (column-name
    47          (exec-query conn "SELECT 1 AS one, 2 AS two") 0))
     47         (query conn "SELECT 1 AS one, 2 AS two") 0))
    4848  (test "Correct column names"
    4949        '(one two)
    5050        (column-names
    51          (exec-query conn "SELECT 1 AS one, 2 AS two")))
     51         (query conn "SELECT 1 AS one, 2 AS two")))
    5252  (test-error "Condition for nonexistant column index"
    5353              (column-name
    54                (exec-query conn "SELECT 1 AS one, 2 AS two") 3))
     54               (query conn "SELECT 1 AS one, 2 AS two") 3))
    5555  (test "Not false for nameless column"
    5656        #f ;; Could check for ?column?, but that's a bit too specific
    5757        (not (column-name
    58               (exec-query conn "SELECT 1, 2") 0)))
     58              (query conn "SELECT 1, 2") 0)))
    5959  ;; Maybe add a few tests here for case folding/noncase folding variants?
    6060  ;; Perhaps column-index-ci vs column-index?  That would be
     
    6464        0
    6565        (column-index
    66          (exec-query conn "SELECT 1 AS one, 2 AS two") 'one))
     66         (query conn "SELECT 1 AS one, 2 AS two") 'one))
    6767  (test "False column index for nonexistant column name"
    6868        #f
    6969        (column-index
    70          (exec-query conn "SELECT 1 AS one, 2 AS two") 'foo))
     70         (query conn "SELECT 1 AS one, 2 AS two") 'foo))
    7171  (test "False oid for virtual table"
    7272        #f
    7373        (table-oid
    74          (exec-query conn "SELECT 1 AS one, 2 AS two") 0))
     74         (query conn "SELECT 1 AS one, 2 AS two") 0))
    7575  (test-assert "Number for nonvirtual table"
    7676               (number?
    7777                (table-oid
    78                  (exec-query conn "SELECT typlen FROM pg_type") 0)))
     78                 (query conn "SELECT typlen FROM pg_type") 0)))
    7979  (test-error "Condition for column index out of bounds"
    8080              (table-oid
    81                (exec-query conn "SELECT typname FROM pg_type") 1))
     81               (query conn "SELECT typname FROM pg_type") 1))
    8282  (test "Table column number for real table"
    8383        0
    8484        (table-column-index
    85          (exec-query conn "SELECT typname FROM pg_type") 0))
     85         (query conn "SELECT typname FROM pg_type") 0))
    8686  (test "Column format is text for normal data"
    8787        'text
    8888        (column-format
    89          (exec-query conn "SELECT 'hello'") 0))
     89         (query conn "SELECT 'hello'") 0))
    9090 
    9191  (test "Column format is binary for forced binary data"
    9292        'binary
    9393        (column-format
    94          (exec-query conn "SELECT 1" '() format: 'binary) 0))
     94         (query* conn "SELECT 1" '() format: 'binary) 0))
    9595 
    9696  (test "Column type OID ok"
    9797        23 ;; from catalog/pg_type.h
    9898        (column-type
    99          (exec-query conn "SELECT 1::int4") 0))
     99         (query conn "SELECT 1::int4") 0))
    100100  (test "Column modifier false"
    101101        #f
    102102        (column-type-modifier
    103          (exec-query conn "SELECT 1") 0))
     103         (query conn "SELECT 1") 0))
    104104  (test "Column modifier for bit ok"
    105105        2
    106106        (column-type-modifier
    107          (exec-query conn "SELECT '10'::bit(2)") 0))
     107         (query conn "SELECT '10'::bit(2)") 0))
    108108  (test "Result value string for strings"
    109109        "test"
    110110        (value-at
    111          (exec-query conn "SELECT 'test'") 0 0))
     111         (query conn "SELECT 'test'") 0 0))
    112112  (test "Result row values"
    113113        '("one" "two")
    114114        (row-values
    115          (exec-query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 0))
     115         (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 0))
    116116  (test "Result row alist"
    117117        '((a . "one") (b . "two"))
    118118        (row-alist
    119          (exec-query conn "SELECT 'one' AS a, 'two' AS b UNION SELECT 'three', 'four'") 0))
     119         (query conn "SELECT 'one' AS a, 'two' AS b UNION SELECT 'three', 'four'") 0))
    120120  (test "Result column values"
    121121        '("one" "three")
    122122        (column-values
    123          (exec-query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 0))
     123         (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 0))
    124124  (test "Result value number for numbers"
    125125        1
    126126        (value-at
    127          (exec-query conn "SELECT 1") 0 0))
     127         (query conn "SELECT 1") 0 0))
    128128  (test "Result value string for raw numbers"
    129129        "1"
    130130        (value-at
    131          (exec-query conn "SELECT 1") 0 0 raw: #t))
     131         (query conn "SELECT 1") 0 0 raw: #t))
    132132  ;; We are using two levels of escaping here because the ::bytea cast
    133133  ;; performs another string interpretation. Yes, this is kinda confusing...
     
    135135        (blob->u8vector (string->blob "h\x00ello"))
    136136        (value-at
    137          (exec-query conn "SELECT E'h\\\\000ello'::bytea") 0 0))
     137         (query conn "SELECT E'h\\\\000ello'::bytea") 0 0))
    138138  (test "Result value for raw null-terminated byte array"
    139139        "h\\000ello"
    140140        (value-at
    141          (exec-query conn "SELECT E'h\\\\000ello'::bytea") 0 0 raw: #t))
     141         (query conn "SELECT E'h\\\\000ello'::bytea") 0 0 raw: #t))
    142142
    143143  (test "Result value blob for binary string"
    144144        (string->blob "hello")
    145145        (value-at
    146          (exec-query conn "SELECT 'hello'" '() format: 'binary) 0 0))
     146         (query* conn "SELECT 'hello'" '() format: 'binary) 0 0))
    147147 
    148148  (test "Result value blob for binary integer"
    149149        (u8vector->blob (u8vector 0 0 0 1))
    150         (value-at (exec-query conn "SELECT 1::int4" '() format: 'binary) 0 0))
     150        (value-at (query* conn "SELECT 1::int4" '() format: 'binary) 0 0))
    151151
    152152  (test "Result value for binary string with NUL bytes"
    153153        (string->blob "h\x00ello")
    154         (value-at (exec-query conn "SELECT E'h\\\\000ello'::bytea" '() format: 'binary) 0 0))
     154        (value-at (query* conn "SELECT E'h\\\\000ello'::bytea" '() format: 'binary) 0 0))
    155155
    156156  (test-assert "Result value sql-null for NULL"
    157157               (sql-null? (value-at
    158                            (exec-query conn "SELECT NULL") 0 0)))
     158                           (query conn "SELECT NULL") 0 0)))
    159159  (test-error "Result value error for out of bounds column"
    160160              (value-at
    161                (exec-query conn "SELECT NULL") 0 1))
     161               (query conn "SELECT NULL") 0 1))
    162162  (test-error "Result value error for out of bounds row"
    163163              (value-at
    164                (exec-query conn "SELECT NULL") 1 0))
     164               (query conn "SELECT NULL") 1 0))
    165165  (test "Number of affected rows false with SELECT"
    166166        #f
    167167        (affected-rows
    168          (exec-query conn "SELECT 1")))
    169 
    170   (exec-query conn "BEGIN")
    171   (exec-query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
     168         (query conn "SELECT 1")))
     169
     170  (query conn "BEGIN")
     171  (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
    172172  (test "Number of affected rows 1 with INSERT"
    173173        1
    174174        (affected-rows
    175          (exec-query conn "INSERT INTO foo (bar) VALUES (1);")))
    176   (exec-query conn "COMMIT")
    177 
    178   (exec-query conn "BEGIN")
    179   (exec-query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
    180   (exec-query conn "INSERT INTO foo (bar) VALUES (100);")
    181   (exec-query conn "INSERT INTO foo (bar) VALUES (101);")
     175         (query conn "INSERT INTO foo (bar) VALUES (1);")))
     176  (query conn "COMMIT")
     177
     178  (query conn "BEGIN")
     179  (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
     180  (query conn "INSERT INTO foo (bar) VALUES (100);")
     181  (query conn "INSERT INTO foo (bar) VALUES (101);")
    182182  (test "Number of affected rows 2 with UPDATE of two rows"
    183183        2
    184184        (affected-rows
    185          (exec-query conn "UPDATE foo SET bar=102;")))
    186   (exec-query conn "COMMIT")
     185         (query conn "UPDATE foo SET bar=102;")))
     186  (query conn "COMMIT")
    187187 
    188188  (test "Inserted OID false on SELECT"
    189189        #f
    190190        (inserted-oid
    191          (exec-query conn "SELECT 1")))
    192 
    193   (exec-query conn "BEGIN")
    194   (exec-query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
     191         (query conn "SELECT 1")))
     192
     193  (query conn "BEGIN")
     194  (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
    195195  (test "Inserted OID false on OID-less table"
    196196        #f
    197197        (inserted-oid
    198          (exec-query conn  "INSERT INTO foo (bar) VALUES (1);")))
    199   (exec-query conn "COMMIT")
    200  
    201   (exec-query conn "BEGIN")
    202   (exec-query conn "CREATE TEMP TABLE foo ( bar integer ) WITH (OIDS=true) ON COMMIT DROP")
     198         (query conn  "INSERT INTO foo (bar) VALUES (1);")))
     199  (query conn "COMMIT")
     200 
     201  (query conn "BEGIN")
     202  (query conn "CREATE TEMP TABLE foo ( bar integer ) WITH (OIDS=true) ON COMMIT DROP")
    203203  (test-assert "Inserted OID number on table with OID"
    204204               (number?
    205205                (inserted-oid
    206                  (exec-query conn "INSERT INTO foo (bar) VALUES (1)"))))
    207   (exec-query conn "COMMIT")
     206                 (query conn "INSERT INTO foo (bar) VALUES (1)"))))
     207  (query conn "COMMIT")
    208208
    209209  (test "regular parameters"
    210210        "hi"
    211         (value-at (exec-query conn "SELECT $1::text" '("hi")) 0 0))
     211        (value-at (query conn "SELECT $1::text" "hi") 0 0))
    212212  (test-assert "NULL parameters"
    213213               (sql-null? (value-at
    214                            (exec-query conn "SELECT $1::text" `(,(sql-null))) 0 0)))
     214                           (query conn "SELECT $1::text" (sql-null)) 0 0)))
    215215  (test "blob parameters"
    216216        "hi"
    217         (value-at (exec-query conn "SELECT $1::text" `(,(string->blob "hi"))) 0 0))
     217        (value-at (query conn "SELECT $1::text" (string->blob "hi")) 0 0))
    218218  (test "boolean parameters"
    219219        '(#t #f)
    220         (row-values (exec-query conn "SELECT $1::bool, $2::bool" '(#t #f)) 0)))
     220        (row-values (query conn "SELECT $1::bool, $2::bool" #t #f) 0)))
    221221
    222222(test-group "value escaping"
     
    264264
    265265(test-group "high-level interface"
    266   (test "query-fold"
     266  (test "row-fold"
    267267        '(("one" 2)
    268268          ("three" 4))
    269269        (reverse
    270          (query-fold
    271           cons '() conn
    272           "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
    273           "one" 2)))
    274   (test "query-fold-right"
    275         '(("one" 2)
    276           ("three" 4))
    277         (query-fold-right
    278          cons '() conn
    279          "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
    280          "one" 2))
    281   (test "query-for-each"
     270         (row-fold
     271          cons '()
     272          (query conn
     273                 "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
     274                 "one" 2))))
     275  (test "row-fold-right"
     276        '(("one" 2)
     277          ("three" 4))
     278        (row-fold-right
     279         cons '()
     280         (query conn
     281                "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
     282                "one" 2)))
     283  (test "row-for-each"
    282284        '(("one" 2)
    283285          ("three" 4))
    284286        (let ((res '()))
    285           (query-for-each
     287          (row-for-each
    286288           (lambda (row) (set! res (cons row res)))
    287            conn
    288            "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2)
     289           (query
     290            conn
     291            "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2))
    289292          (reverse res)))
    290   (test "query-map"
    291         '(("one" 2)
    292           ("three" 4))
    293         (query-map
    294          identity conn
    295          "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2)))
     293  (test "row-map"
     294        '(("one" 2)
     295          ("three" 4))
     296        (row-map
     297         identity
     298         (query conn
     299                "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2))))
Note: See TracChangeset for help on using the changeset viewer.