;;; Project: Scheme-PG ;;; Author: David J. Neu, [email protected] ;;; Maintainer: David J. Neu, [email protected] ;;; Project Home Page: http://scheme-pg.sourceforge.net ;;; Copyright: Copyright (c) 2004 Universal Technical Resource Services, Inc. ;;; License: MIT License, see license.txt ;;; CVS Id: $Id: sql.ss,v 1.9 2005/03/21 20:24:18 djneu Exp $ (module sql mzscheme (require (only (lib "13.ss" "srfi") string-drop-right string-drop) (lib "string.ss") (lib "s-pg.ss" "scheme-pg")) ; only needed for the esacpe-string call in format-value (define-syntax where-clause-and (syntax-rules () ((_) '()) ((_ e) (list e)) ((_ e1 e2 e3 ...) (append (list e1 "AND") (where-clause-and e2 e3 ...))))) (define-syntax where-clause-or (syntax-rules () ((_) '()) ((_ e) (list e)) ((_ e1 e2 e3 ...) (append (list e1 "OR") (where-clause-or e2 e3 ...))))) (define operator? (lambda (aoperator) (symbol? aoperator))) (define format-operator (lambda (aoperator) (if (operator? aoperator) (string-upcase (format "~a" aoperator)) (error 'format-operator "expects a symbol, given: ~a" aoperator)))) ;;; column-name?: column -> boolean ;;; Returns #t if acolumn is a symbol and #f otherwise (define column-name? (lambda (acolumn) (symbol? acolumn))) ;;; format-column-name: symbol -> string ;;; Accepts a symbol representing a column name and returns a string ;;; containing the symbol surrounded by double quotes. This allows ;;; programmers to use column names that for example contain spaces or ;;; dashes. (define format-column-name (lambda (acolumn) (format "\"~a\"" acolumn))) ;;; as-column-name?: column -> boolean ;;; Returns #t if acolumn is a length three proper list of symbols ;;; with the first symbol being AS, and the second and third ;;; satisfying column-name?, and #f otherwise. For example, (as first-name fn). (define as-column-name? (lambda (acolumn) (and (list? acolumn) (= (length acolumn) 3) (eq? (car acolumn) 'as) (column-name? (cadr acolumn)) (column-name? (caddr acolumn))))) ;;; function?: function -> boolean ;;; Returns #t if afunction is a symbol that starts with a :. (define function? (lambda (afunction) (and (symbol? afunction) (eq? (string-ref (symbol->string afunction) 0) #\:)))) ;;; function/column-name?: column -> boolean ;;; Returns #t if acolumn is a length two proper list of symbols with ;;; the first symbol satisfying function?, and the second symbol ;;; satisfying column-name?, and #f otherwise. For example, (:avg ;;; age). (define function/column-name? (lambda (acolumn) (and (list? acolumn) (= (length acolumn) 2) (function? (car acolumn)) (column-name? (cadr acolumn))))) ;;; format-function/column-name: column -> string ;;; Accepts an argument acolumn that satifies function/column-name? ;;; and returns a string. For example, (:avg age) => avg("age"). ;;; Surroudding the column names by double quotes allows programmers ;;; to use column name that contain contain spaces or dashes. (define format-function/column-name (lambda (acolumn) (let ((lfunction (cadr (regexp-split ":" (symbol->string (car acolumn)))))) (format "~a(\"~a\")" lfunction (cadr acolumn))))) ;;; format-column-name: symbol -> string ;;; Accepts an argument acolumn that satifies as-column-name? and ;;; returns a string. For example, (as first-name fn) => "first-name" ;;; AS "fn". Surroudding the column names by double quotes allows ;;; programmers to use column name that contain contain spaces or ;;; dashes. (define format-as-column-name (lambda (acolumn) (format "\"~a\" AS \"~a\"" (cadr acolumn) (caddr acolumn)))) ;;; table-name/column-name?: column -> boolean ;;; Returns #t if acolumn is a length two proper list of symbols and ;;; #f otherwise. (define table-name/column-name? (lambda (acolumn) (and (list? acolumn) (= (length acolumn) 2) (symbol? (car acolumn)) (symbol? (cadr acolumn))))) ;;; format-table-name/column-name: symbol -> string ;;; Accepts a length two proper list of symbols symbol, representing a ;;; table name and a column name and returns a string of the form ;;; "table"."column" where table is the table name and column is the ;;; column name. This allows programmers to use table and column names ;;; that for example contain spaces or dashes. (define format-table-name/column-name (lambda (acolumn) (format "\"~a\".\"~a\"" (car acolumn) (cadr acolumn)))) ;;; as-table-name/column-name?: column -> boolean ;;; Returns #t if acolumn is a length three proper list with the first ;;; symbol being AS, the second satisfying table-name/column-name? and ;;; the third satisfying column-name?, and #f otherwise. For example, ;;; (as (person first-name) fn). (define as-table-name/column-name? (lambda (acolumn) (and (list? acolumn) (= (length acolumn) 3) (eq? (car acolumn) 'as) (table-name/column-name? (cadr acolumn)) (column-name? (caddr acolumn))))) ;;; format-as-table-name/column-name: symbol -> string ;;; Accepts an argument acolumn that satifies ;;; as-table-name/column-name? and returns a string. For example, (as ;;; (person first-name) fn) => "person.first-name" AS "fn". ;;; Surroudding the column names by double quotes allows programmers ;;; to use column name that contain contain spaces or dashes. (define format-as-table-name/column-name (lambda (acolumn) (format "~a AS \"~a\"" (format-table-name/column-name (cadr acolumn)) (caddr acolumn)))) ;;; function/table-name/column-name?: column -> boolean ;;; Returns #t if acolumn is a length two proper list with the first ;;; element satifying function? and the second satifying ;;; table-name/column-name?, and #f otherwise. (define function/table-name/column-name? (lambda (acolumn) (and (list? acolumn) (= (length acolumn) 2) (function? (car acolumn)) (table-name/column-name? (cadr acolumn))))) ;;; format-function/table-name/column-name: symbol -> string ;;; Accepts an argument acolumn that satifies ;;; function-table-name/column-name? and returns a string. For ;;; example, (:avg (pers age)) => avg("pers"."age"). (define format-function/table-name/column-name (lambda (acolumn) (let ((lfunction (cadr (regexp-split ":" (symbol->string (car acolumn)))))) (format "~a(~a)" lfunction (format-table-name/column-name (cadr acolumn)))))) ;;; schema-name/column-name/table-name?: column -> boolean ;;; Returns #t if acolumn is a length three proper list of symbols and ;;; #f otherwise. (define schema-name/table-name/column-name? (lambda (acolumn) (and (list? acolumn) (= (length acolumn) 3) (symbol? (car acolumn)) (symbol? (cadr acolumn)) (symbol? (caddr acolumn))))) ;;; format-scheme-name/table-name/column-name: symbol -> string ;;; Accepts a length three proper list of symbols symbol, representing ;;; a schema name, a table name and a column name and returns a string ;;; of the form "schema"."table"."column" where schema is the name of ;;; the schema, table is the table name and column is the column ;;; name. This allows programmers to use table and column names that ;;; for example contain spaces or dashes. (define format-schema-name/table-name/column-name (lambda (acolumn) (format "\"~a\".\"~a\".\"~a\"" (car acolumn) (cadr acolumn) (caddr acolumn)))) ;;; as-schema-name/table-name/column-name?: column -> boolean ;;; Returns #t if acolumn is a length three proper list with the first ;;; symbol being AS, the second satisfying table-name/column-name? and ;;; the third satisfying column-name?, and #f otherwise. For example, ;;; (as (myschema person first-name) fn). (define as-schema-name/table-name/column-name? (lambda (acolumn) (and (list? acolumn) (= (length acolumn) 3) (eq? (car acolumn) 'as) (schema-name/table-name/column-name? (cadr acolumn)) (column-name? (caddr acolumn))))) ;;; format-as-schema-name/table-name/column-name: symbol -> string ;;; Accepts an argument acolumn that satifies ;;; as-schema-name/table-name/column-name? and returns a string. For ;;; example, (as (myschema person first-name) fn) => ;;; "myschema.person.first-name" AS "fn". Surroudding the column ;;; names by double quotes allows programmers to use column name that ;;; contain contain spaces or dashes. (define format-as-schema-name/table-name/column-name (lambda (acolumn) (format "~a AS \"~a\"" (format-schema-name/table-name/column-name (cadr acolumn)) (caddr acolumn)))) ;;; schema-name/column-name/table-name?: column -> boolean ;;; Returns #t if acolumn is a length two proper list with the first ;;; element satisfying function? and the second satifying ;;; schema-name/table-name/column-name?, and #f otherwise. (define function/schema-name/table-name/column-name? (lambda (acolumn) (and (list? acolumn) (= (length acolumn) 2) (function? (car acolumn)) (schema-name/table-name/column-name? (cadr acolumn))))) ;;; format-scheme-name/table-name/column-name: symbol -> string ;;; Accepts a length three proper list of symbols symbol, representing ;;; a schema name, a table name and a column name and returns a string ;;; of the form "schema"."table"."column" where schema is the name of ;;; the schema, table is the table name and column is the column ;;; name. This allows programmers to use table and column names that ;;; for example contain spaces or dashes. (define format-function/schema-name/table-name/column-name (lambda (acolumn) (let ((lfunction (cadr (regexp-split ":" (symbol->string (car acolumn)))))) (format "~a(~a)" lfunction (format-schema-name/table-name/column-name (cadr acolumn)))))) ;;; column?: column -> boolean ;;; Returns #t when acolumn is either a Scheme symbol representing a ;;; column name or a proper list of length 2 of symbols representing a ;;; table name and a column name and returns #f otherwise. (define column? (lambda (acolumn) (cond ((column-name? acolumn) #t) ((as-column-name? acolumn) #t) ((function/column-name? acolumn) #t) ((table-name/column-name? acolumn) #t) ((as-table-name/column-name? acolumn) #t) ((function/table-name/column-name? acolumn) #t) ((schema-name/table-name/column-name? acolumn) #t) ((as-schema-name/table-name/column-name? acolumn) #t) ((function/schema-name/table-name/column-name? acolumn) #t) (else #f)))) ;;; format-column: acolumn -> string ;;; Returns a string representing column when acolumn is in either of ;;; the two valid column formats. Otherwise it raises an exception. (define format-column (lambda (acolumn) (cond ((column-name? acolumn) (format-column-name acolumn)) ((as-column-name? acolumn) (format-as-column-name acolumn)) ((function/column-name? acolumn) (format-function/column-name acolumn)) ((table-name/column-name? acolumn) (format-table-name/column-name acolumn)) ((as-table-name/column-name? acolumn) (format-as-table-name/column-name acolumn)) ((function/table-name/column-name? acolumn) (format-function/table-name/column-name acolumn)) ((schema-name/table-name/column-name? acolumn) (format-schema-name/table-name/column-name acolumn)) ((as-schema-name/table-name/column-name? acolumn) (format-as-schema-name/table-name/column-name acolumn)) ((function/schema-name/table-name/column-name? acolumn) (format-function/schema-name/table-name/column-name acolumn)) (else (error 'format-column "expects a symbol, or a length two proper list of symbols, or a length two proper list of symbols given: ~a" acolumn))))) (define format-value-string "format-value: expects a symbol or a length two proper list of symbols to be used as a column or number or string to be used as a value, given: ~a") ;;; In procedure format-value a value can either be a valid Scheme-PG ;;; column (see column? for the definition), or it can be a valid ;;; Scheme-PG value. The first case occurs in a condition in which ;;; the values of two database columns are compared. For example, ;;; SELECT * FROM pers WHERE first-name = last-name ;;; and ;;; SELECT * FROM pers,addr WHERE pers.id = addr.id. ;;; The second case occurs in a condition in which the value of a ;;; database column is compared to a constant. For example, ;;; SELECT * FROM pers WHERE last-name LIKE 'Do%' ;;; and ;;; SELECT * FROM pers WHERE age < 22. ;;; If avalue is a valid column it is formatted as one by calling ;;; format-column. If avalue is not a valid column then there are two ;;; valid situtations: it is a string or it is a number. If avalue is ;;; a string, escape-value is applied and the result is surrounded by ;;; single quotes. If avalue is a number it returned as a string ;;; without any additional formatting. In all other cases an ;;; exception is raised. An example of an additional Scheme data type ;;; that could be supported is a list, which could be used in an SQL ;;; IN, e.g. SELECT * FROM addr WHERE state IN ('NH', 'NJ', 'NY'). (define format-value (lambda (avalue) (cond ((null-object? avalue) "NULL") ((column? avalue) (format-column avalue)) ((string? avalue) (format "'~a'" (escape-string avalue))) ((number? avalue) (format "~a" avalue)) (else (error 'format-value format-value-string avalue))))) (define-syntax where-clause (syntax-rules (and or not) ((where-clause (not x)) (format "NOT ~a" (where-clause x))) ;; this would add parentheses ;;((where-clause (not x)) (list "NOT" (where-clause x))) ((where-clause (and x)) (where-clause x)) ((where-clause (and x y ...)) (where-clause-and (where-clause x) (where-clause y) ...)) ((where-clause (or x)) (where-clause x)) ((where-clause (or x y ...)) (where-clause-or (where-clause x) (where-clause y) ...)) ((where-clause (operator column value)) ;; this would add parentheses ;;(list (format "~a ~a ~a" (format-column `column) (format-operator `operator) (format-value `value)))))) (format "~a ~a ~a" (format-column `column) (format-operator `operator) (format-value `value))))) (define-syntax where (syntax-rules () ((_ . expr) (let ((lwhere-clause (where-clause . expr))) (if (null? lwhere-clause) "" (let ((lwhere-string (format "~a" lwhere-clause))) ;; remove redundant outer parentheses (if (and (eq? (string-ref lwhere-string 0) #\() (eq? (string-ref lwhere-string 0) #\()) (format "WHERE ~a " (string-drop-right (string-drop lwhere-string 1) 1)) (format "WHERE ~a " lwhere-string)))))))) (define-syntax comma-separate (syntax-rules () ((_) "") ((_ e) e) ((_ e1 e2 e3 ...) (format "~a,~a" e1 (comma-separate e2 e3 ...))))) (define-syntax space-separate (syntax-rules () ((_) "") ((_ e) e) ((_ e1 e2 e3 ...) (format "~a ~a" e1 (space-separate e2 e3 ...))))) ;;; table-name?: table-name -> boolean ;;; Returns #t if atable is a symbol and #f otherwise (define table-name? (lambda (atable) (symbol? atable))) ;;; schema-name/table-name?: column -> boolean ;;; Returns #t if atable is a length two proper list of symbols and ;;; #f otherwise. (define schema-name/table-name? (lambda (atable) (and (list? atable) (= (length atable) 2) (symbol? (car atable)) (symbol? (cadr atable))))) ;;; format-table-name: symbol -> string ;;; Accepts a symbol representing a table name and returns a string ;;; containing the symbol surrounded by double quotes. This allows ;;; programmers to use table names that for example contain spaces or ;;; dashes. (define format-table-name (lambda (atable) (format "\"~a\"" atable))) ;;; format-schema-name/table-name: symbol -> string ;;; Accepts a length two proper list of symbols symbol, representing a ;;; scheme name and a table name and returns a string of the form ;;; "schema"."table" where schema is the schema name and table is the ;;; table name. This allows programmers to use schema and table names ;;; that for example contain spaces or dashes. (define format-schema-name/table-name (lambda (atable) (format "\"~a\".\"~a\"" (car atable) (cadr atable)))) ;;; format-table: atable -> string ;;; Returns a string representing table when atable is in either of ;;; the two valid table formats. Otherwise it raises an exception. (define format-table (lambda (atable) (cond ((table-name? atable) (format-table-name atable)) ((schema-name/table-name? atable) (format-schema-name/table-name atable)) (else (error 'format-table "expects a symbol or a length two proper list of symbols, given: ~a" atable))))) ;;; This macro contains two rules that generate a SELECT statement, ;;; they are matched depending on whether a list of columns is ;;; explicitly specified or the literal all is used. The macro ;;; expects a list of columns, a list of tables and zero or more ;;; strings containings where, order-by, or other clauses. (define-syntax select (syntax-rules (all) ((_ (column ...) (table ...) clause ...) (format "SELECT ~a FROM ~a ~a" (comma-separate (format-column `column) ...) (comma-separate (format-table `table) ...) (space-separate clause ...))) ((_ all (table ...) clause ...) (format "SELECT * FROM ~a ~a" (comma-separate (format-table `table) ...) (space-separate clause ...))))) ;;; The select-distinct macro is the same as the select macro except ;;; that it creates a SELECT DISTINCT rather than a SELECT. (define-syntax select-distinct (syntax-rules (all) ((_ (column ...) (table ...) clause ...) (format "SELECT DISTINCT ~a FROM ~a ~a" (comma-separate (format-column `column) ...) (comma-separate (format-table `table) ...) (space-separate clause ...))) ((_ all (table ...) clause ...) (format "SELECT DISTINCT * FROM ~a ~a" (comma-separate (format-table `table) ...) (space-separate clause ...))))) ;;; limit: non-negative-integer non-negative-integer -> string ;;; The limit macro creates a LIMIT clause for use in a SELECT ;;; statement. The offset argument is the number of rows to be ;;; skipped, so an offset of 0 means that the first row returned will ;;; be the first row of the result. The number argument is an upper ;;; bound on the number of rows to return. Less than number rows can ;;; be returned depending on the number of rows in the result and the ;;; value of offset. ;;; ;;; (limit 5 10) => OFFSET 5 LIMIT 10 (define-syntax limit (syntax-rules () ((_ offset number) (format "OFFSET ~a LIMIT ~a" `offset `number)))) (define format-asc/desc (lambda (x) (cond ((eq? x 'asc) "ASC") ((eq? x 'desc) "DESC") (else (error 'format-asc/desc "expects the symbol 'ASC or the symbol 'DESC, given: ~a" x))))) ;;; order-by: (listof (symbol 'asc or 'desc)) -> string ;;; The order-by macro creates an ORDER BY clause for use in a SELECT. ;;; It accepts a proper list of length two lists that consists of a ;;; symbol representing a column name and either the symbol asc (to ;;; indicate the result should be put in ascending order) or the ;;; symbol desc (to indicate the result should be put in descending ;;; order). ;;; ;;;(order-by ((first-name asc)(last-name DESC))) => ORDER BY "first-name" ASC, "last-name" DESC (define-syntax order-by (syntax-rules () ((_ ((column asc/desc) ...)) (format "ORDER BY ~a" (comma-separate (format "~a ~a" (format-column `column) (format-asc/desc `asc/desc)) ...))))) ;;; The insert macro has four rules that support the creation of ;;; INSERT statements. ;;; ;;; The following form constructs the INSERT statement shown: ;;; (insert pers (1 "John" "Doe" 20)) ; rule 3 ;;; => INSERT INTO "pers" VALUES (1,'John','Doe',20) ;;; ;;; The following three forms all construct the same INSERT statement: ;;; (insert pers (id first-name last-name age) (1 "John" "Doe" 20)) ; rule 4 ;;; (insert pers ((id . 1) (first-name . "John") (last-name . "Doe") (age . 20))) ; rule 2 ;;; (insert pers ((id 1) (first-name "John") (last-name "Doe") (age 20))) ; rule 1 ;;; => INSERT INTO "pers" ("id","first-name","last-name","age") VALUES (1,'John','Doe',20) ;;; ;;; The following examples demonstrates how to insert a NULL value: ;;; (insert pers (1 "John" null-object 20)) ;;; => INSERT INTO "pers" VALUES (1,'John',NULL,20) ;;; ;;; (define last-name 'null-object) ;;; (insert pers (1 "John" ,x 20)) ;;; => INSERT INTO "pers" VALUES (1,'John',NULL,20) (define-syntax insert (syntax-rules () ((_ table ((column value) ...)) ; rule 1 (format "INSERT INTO ~a (~a) VALUES (~a)" (format-table `table) (comma-separate (format-column `column) ...) (comma-separate (format-value `value) ...))) ((_ table ((column . value) ...)) ; rule 2 (format "INSERT INTO ~a (~a) VALUES (~a)" (format-table `table) (comma-separate (format-column `column) ...) (comma-separate (format-value `value) ...))) ((_ table (value ...)) ; rule 3 (format "INSERT INTO ~a VALUES (~a)" (format-table `table) (comma-separate (format-value `value) ...))) ((_ table (column ...) (value ...)) ; rule 4 (format "INSERT INTO ~a (~a) VALUES (~a)" (format-table `table) (comma-separate (format-column `column) ...) (comma-separate (format-value `value) ...))))) ;;; The delete macro has two rules that support the creation of DELETE ;;; statements as shown in the examples below: ;;; (delete pers) ;;; => DELETE FROM "pers" ;;; ;;; (delete pers (where (and (< age 45) (= state "NJ")))) ;;; => DELETE FROM "pers" WHERE "age" < 45 AND "state" = 'NJ' (define-syntax delete (syntax-rules (all) ((_ table) (format "DELETE FROM ~a" (format-table `table))) ((_ table where-clause) (format "DELETE FROM ~a ~a" (format-table `table) where-clause)))) ;;; The update macro has six rules that support the creation of ;;; UPDATE statements. ;;; ;;; The following three forms all construct the same UPDATE statement: ;;; (update pers ((first-name "John") (age 20))) ; rule 1 ;;; (update pers ((first-name . "John") (age . 20))) ; rule 2 ;;; (update pers ((first-name age) ("John" 20))) ; rule 3 - does not work ;;; => UPDATE pers SET "first-name"='John', "age"=20 ;;; ;;; The following three forms all construct the same UPDATE statement: ;;; (update pers ((first-name "John") (age 20)) (where (= last-name "Doe"))) ; rule 1a ;;; (update pers ((first-name . "John") (age . 20)) (where (= last-name "Doe"))) ; rule 2a ;;; (update pers ((first-name age) ("John" 20)) (where (= last-name "Doe"))) ; rule 3a - does not work ;;; => UPDATE pers SET "first-name"='John', "age"=20 WHERE "age" < 20 ;;; ;;; The following examples demonstrates how to update a NULL value: ;;; (update pers ((first-name "John") (age null-object))) ;;; => UPDATE pers SET "first-name"='John', "age"=NULL (define-syntax update (syntax-rules (where) ((_ table ((column value) ...)) ; rule 1 (format "UPDATE ~a SET ~a" (format-table `table) (comma-separate (format "~a=~a" (format-column `column) (format-value `value)) ...))) ((_ table ((column value) ...) where-clause) ; rule 1a (format "UPDATE ~a SET ~a ~a" (format-table `table) (comma-separate (format "~a=~a" (format-column `column) (format-value `value)) ...) where-clause)) ((_ table ((column . value) ...)) ; rule 2 (format "UPDATE ~a SET ~a" (format-table `table) (comma-separate (format "~a=~a" (format-column `column) (format-value `value)) ...))) ((_ table ((column . value) ...) where-clause) ; rule 2a (format "UPDATE ~a SET ~a ~a" (format-table `table) (comma-separate (format "~a=~a" (format-column `column) (format-value `value)) ...) where-clause)))) ; ((_ table (column ...) (value ...)) ; rule 3 ; (format "UPDATE ~a SET ~a" (format-table `table) ; (comma-separate (format "~a=~a" (format-column `column) (format-value `value)) ...))) ; ((_ table (column ...) (value ...) where-clause) ; rule 3a ; (format "UPDATE ~a SET ~a ~a" (format-table `table) ; (comma-separate (format "~a=~a" (format-column `column) (format-value `value)) ...) ; where-clause)))) (provide where select select-distinct limit order-by insert update delete ))