File: sqlite3.lsp

package info (click to toggle)
newlisp 10.7.1-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 8,460 kB
  • ctags: 4,357
  • sloc: ansic: 33,202; lisp: 7,369; java: 7,012; sh: 647; makefile: 273
file content (504 lines) | stat: -rw-r--r-- 17,587 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
;; @module sqlite3.lsp 
;; @description SQLite3 database interface routines
;; @version 1.6 - comments redone for automatic documentation
;; @version 1.7 - D.C. fixed getting types when null values are present
;; @version 1.8 - D.C. made 64-Bit integers work
;; @version 1.9 - new library detection routine
;; @version 2.0 - added documentation for close
;; @version 2.1 - use default functor for query
;; @version 2.2 - detection for NEWLISP64, lib path for OpenBSD, tested for 64-bit 
;; @version 2.3 - C.H. added parameter binding for safer SQL (guard against SQL-injection)
;; @version 2.4 - doc changes
;; @version 2.5 - changed sqlite3_bind_blob to sqlite3_bind_text in function bind-parameter
;; @version 2.61 - added function  <tt>sql3:colnames</tt>.
;; @version 2.7 - changed deprecated <tt>name</tt> to <tt>term</tt>, <tt>inc</tt> to <tt>++</tt>
;; @version 2.71 - minor doc changes
;; @version 2.72 - add support for CentOS 6 Linux 64Bit
;; @version 2.73 - doc additions
;; @version 2.83- added sqlite3 library path for UBUNTU 12.04/10 64-bit and others
;; @author Lutz Mueller 2004-2013, Dmitri Cherniak 2007, Clemens Hintze 2009
;;
;; <h2>Module for SQLite3 database bindings</h2>
;; To use this module include the following 'load'  or 'module' statement at the
;; beginning of the program file:
;; <pre>
;; (load "/usr/share/newlisp/modules/sqlite3.lsp")
;; ; or shorter
;; (module "sqlite3.lsp")
;; </pre>
;; Test the module:
;; <pre>
;; (test-sqlite3)
;; </pre>
;; This function, located at the and of the module file, exercises
;; most of the functions.
;;
;; SQLite version 3.0 introduced a new database format and is incompatible
;; whith the previous 2.1 to 2.8 format. Old SQLite 2.x based databases can
;; be converted  using the old and new sqlite client application:
;;
;;    sqlite OLD.DB .dump | sqlite3 NEW.DB
;;
;; While in sqlite 2.8 all returned fields where of string type, SQLite3
;; returns, text, integer or float. Blobs are returned as text and NULLs
;; are returned as nil.
;;
;; See also the documentation at @link http://sqlite.org sqlite.org
;;
;; <h2>Requirements:</h2> 
;; One of the libraries sqlite3.dll for MS Windows or libsqlite3.so for UNIX like
;; operating systems is required from http://www.sqlite.org.
;;
;; SQLite is an <in-process> database. The library contains the whole database
;; system. An extra database server is not required. SQLite also has limited
;; mutiuser capabilities for accessing a common database from several programs
;; at the same time. See the documentation at @link http://sqlite.org sqlite.org 
;; for details.
;;
;; The following is a short example how to use SQLite3:
;;
;; @example
;; (sql3:open "MYDB")      ; opens/creates a database returns a handle (ignore)
;;                         ; or 'nil' on failure
;;
;; (sql3:sql "select * from mytable;")	; make a SQL query, return result
;; (sql3 "select * from mytable;") ; use default functor as alias
;;
;; (sql3:error)            ; return error text
;;
;; (sql3:close)            ; close the database

;; Function calls returning 'nil' signal that an error has occurred. The
;; function 'sql3:error' can then be used to get details about the error
;; as a text string.
;;
;; At the bottom of the source file 'sqlite3.lsp' a test routine called
;; 'test-sqlite3' can be found to test for correct installation of SQLite.

; make this module compatible with version less than 10.1.11
(when (< (sys-info -2) 10111)
	(constant (global 'term) name))

(when (< (sys-info -2) 10110)
	(constant (global '++) inc))

(context 'sql3)

; fetch-row and keep-type functions depend on this
(set 'NEWLISP64 (not (zero? (& (sys-info -1) 256))))

(set 'library "libsqlite3.so")

(import library "sqlite3_open" "cdecl")
(import library "sqlite3_close" "cdecl")
(import library "sqlite3_prepare" "cdecl")
(import library "sqlite3_bind_blob" "cdecl")
(import library "sqlite3_bind_double" "cdecl")
(import library "sqlite3_bind_null" "cdecl")
(import library "sqlite3_bind_parameter_count" "cdecl")
(import library "sqlite3_bind_parameter_index" "cdecl")
(import library "sqlite3_bind_parameter_name" "cdecl")
(import library "sqlite3_bind_text" "cdecl")
(import library "sqlite3_bind_text16" "cdecl")
(import library "sqlite3_step" "cdecl")
(import library "sqlite3_column_count" "cdecl")
(import library "sqlite3_column_name" "cdecl")
(import library "sqlite3_column_type" "cdecl")
(import library "sqlite3_column_int64" "cdecl")
(import library "sqlite3_column_double" "cdecl")
(import library "sqlite3_column_text" "cdecl")
(import library "sqlite3_column_blob" "cdecl")
(import library "sqlite3_column_bytes" "cdecl")
(import library "sqlite3_finalize" "cdecl")
(import library "sqlite3_get_table" "cdecl")
(import library "sqlite3_last_insert_rowid" "cdecl")
(import library "sqlite3_changes" "cdecl")
(import library "sqlite3_busy_timeout" "cdecl")
(import library "sqlite3_errmsg" "cdecl")


; gloablly used vars and constants

(define db nil)                  ; database handle
(define dbp "\000\000\000\000\000\000\000\000")  ; ptr to database handle
(define error-message nil)        ; error message
(define col-names '())           ; list of column headers
(define col-types '())           ; list of column types
(define pstm "\000\000\000\000\000\000\000\000") ; ptr to compiled sql

(constant 'SQLITE_OK 0)
(constant 'SQLITE_ROW 100)
(constant 'SQLITE_DONE 101)

(constant 'SQLITE_TYPES '(
	0 
	SQLITE_INTEGER 
	SQLITE_FLOAT 
	SQLITE_TEXT 
	SQLITE_BLOB 
	SQLITE_NULL))

;; @syntax (sql3:open <str-db-name>)
;; @param <str-db-name> The name of the database.
;; @return A database handle (discard), or 'nil' on failure.
;; Opens or creates a database. If the database does exist it gets opened, 
;; else a new database with the name given is created.
;; If trying to open a database that already has been opened 'nil' is returned
;; and an error text can be retrieved using 'sql3:error'.

(define (sql3:open db-name)
  ; only open if not alrady done
  (if (not db)
    (begin
      (set 'result (sqlite3_open db-name dbp))
      (if (!= result SQLITE_OK)
        (set 'db nil)
        (if NEWLISP64
            (set 'db (get-long dbp))
            (set 'db (get-int dbp)))
      ))
    (begin
      (set 'error-message "A database is already open")
      nil))
)

;; @syntax (sql3:close)
;; @return Returns 'true' on success;
;; Closes the currently open database.

(define (sql3:close) 		;;  overwrite the close in MAIN
	(if db (begin
		(sqlite3_close db)
		(set 'db nil)
		true)))


;; @syntax (sql3:sql <str-sql> [<sql-args>])
;; @param <str-sql> The SQL statement.
;; @param <sql-args> Parameters for the SQL statement's host variables
;;
;; Executes the SQL statement in <str-sql>. For 'select' statements a table
;; of the result set is returned or '()' for the empty set. For other statements
;; 'true' is returned for a  successful outcome. On failure 'nil' is returened 
;; and 'sql3:error' can be used to retrieve the error text.
;;
;; If the parameter <sql-args> is given, it has either to be a list of values (if
;; the SQL statement use the '?' type of host variables) or an association list
;; whose every association is formed like (<varname> <value>). The <varname> is
;; the name of the host variable used in the SQL statement e.g. ':name' or '?123'.
;;
;; Strings are bound to host variables as BLOBs. That mean the data will be passed
;; as is, without any further modification.
;;
;; Using host variables is much safer than passing those values via string
;; composition as no SQL quoting problem can occur (SQL injection attack).
;; For example:
;;
;; @example
;; ; traditional usage 
;; (sql3:sql "select * from persons where age > 18;") 
;;
;; ; safer usage using SQLite parameter binding
;; (sql3:sql "select * from persons where age > ?;" '(18))
;;
;; ; bind parameters from association lists
;; (sql3:sql "select * from persons where name like :name;" '((":name" "Do%")))
;; (sql3:sql "select * from persons where age > :a and name like :n;" '((":n" "Do%") (":a" 18)))


(define (sql sql-str sql-args)
	(set 'result nil 'done nil 'error-message nil)
	(set 'sqarray '());
	(set 'col-names '());
	(set 'col-types '());

	; set up parameters for sqlite3_prepare() call
	(set 'ppstm "\000\000\000\000\000\000\000\000") ; pointer to statement ptr
	(set 'pptail "\000\000\000\000\000\000\000\000") ; pointer to statement tail

	; compile the sql statment
	(if db (set 'result (sqlite3_prepare db sql-str -1 ppstm pptail)))

	; set up parameters for sqlite3_step() call
	(if NEWLISP64
		(set 'pstm (get-long ppstm))
		(set 'pstm (get-int ppstm)))

	; bind parameters to sql stament if necessary
	(if (and (= result SQLITE_OK) sql-args)
  		(let (argi 0)
    			(dolist (entry sql-args (!= result SQLITE_OK))
      				(if (list? entry) 
        				(set 'result (bind-parameter pstm (first entry) (last entry)))
        				(set 'result (bind-parameter pstm (++ argi) entry))
				)))
	)

	; execute the compiled statement
	(if (= result SQLITE_OK) 
		(while (not done) 
			;; execute statement until done/101 or 
			(set 'result (sqlite3_step pstm))
			(set 'num-cols (sqlite3_column_count pstm))
			(if (empty? col-names) (set 'col-names (get-names pstm num-cols)))
			(set 'col-types (get-types pstm num-cols))
			(if (= result SQLITE_ROW)
				(push (get-values pstm num-cols) sqarray -1)
				(set 'done true) ;; received done/101 or error
			))
  	)
  
	; if done/101 finalize
	(if (= result SQLITE_DONE) 
		(begin
			(set 'result (sqlite3_finalize pstm))
			; for 'select' statements return the array else 'true'
			(if (> num-cols 0) sqarray true))
		(if (= result 0) true (set-error))))


(define (bind-parameter pstm param value)
	(let (idx param)
		(unless (integer? param)
			(set 'idx (sqlite3_bind_parameter_index pstm
				(if (symbol? param) (term param) (string param)))))
		(cond
			((float? value) (sqlite3_bind_double pstm idx (float value)))
			;((string? value) (sqlite3_bind_blob pstm idx value (length value) -1))
			((string? value) (sqlite3_bind_text pstm idx value (length value) -1))
			((nil? value) (sqlite3_bind_null pstm idx))
			(true (sqlite3_bind_text pstm idx (string value) (length (string value)) -1)) )) )


(define (get-values pstm cols) 
	(set 'row '())
	(dotimes (idx cols)
		(set 'i (int idx)) ; all loop vars are float
		(case (nth idx col-types idx)
;			(SQLITE_INTEGER 
;				(push (sqlite3_column_int pstm i) row -1))
;			fixed for 64-bit, thanks Dmitry
			(SQLITE_INTEGER 
				(set 'pstr (sqlite3_column_text pstm i)) 
				(if (= pstr 0) 
					(push nil row -1) 
					(push (int (get-string pstr)) row -1))) 
			(SQLITE_FLOAT 
				(set 'pstr (sqlite3_column_text pstm i))
				(if (= pstr 0)
					(push nil row -1)
					(push (float (get-string pstr)) row -1)))
			(SQLITE_TEXT 
				(set 'pstr (sqlite3_column_text pstm i))
				(if (= pstr 0)
					(push "" row -1)
					(push (get-string pstr) row -1)))
			(SQLITE_BLOB 
				(set 'pstr (sqlite3_column_blob pstm i))
				(set 'len (sqlite3_column_bytes pstm i))
				(set 'buff (dup "\000" len))
				(if (= pstr 0)
					(push "" row -1)
					(begin
						(cpymem pstr buff len)
						(push buff row -1))))
			(SQLITE_NULL 
				(push nil row -1))))
	row)

(define (get-names pstm cols) 
	(set 'row '())
	(dotimes (idx cols)
		(set 'i (int idx)) ; all loop vars are float
		(set 'ps (sqlite3_column_name pstm i))
		(if (= ps 0)	       ;; check for null pointer to result
			(push "" row -1)
			(push (get-string ps) row -1)))
	row)

(define (get-types pstm cols)
	(set 'row '())
	(dotimes (idx cols)
		(set 'i (int idx)) ; all loop vars are float
		(push (nth (sqlite3_column_type pstm i) SQLITE_TYPES) row -1))
	row)

(define sql3:sql3 sql)

;; @syntax (sql3:colnames)
;; @return A list of column header names.
;; Returns a list of column header names for the last query. This is
;; a function wrapper around the internal variable <tt>sql3:col-names</tt>.

(define (colnames) col-names)


;; @syntax (sql3:rowid)
;; @return The last row id from last 'insert'.
;; Gets the id of the last row inserted.

(define (rowid)
	(if db (sqlite3_last_insert_rowid db)))

;; @syntax (sql3:tables)
;; @return A list of tables in the database.

(define (tables)
	(if db (begin
		(set 'lst (sql "select tbl_name from sqlite_master")) ))
		(if lst (set 'lst (first (transpose lst)))))


;; @syntax (sql3:columns <str-tabel-name>)
;; @return A list of column names for a table.

(define (columns aTable)
        (if (list? (sql (append "select * from " aTable " where 0;")))
                col-names))


;; @syntax (sql3:changes)
;; @return The Number of rows changed/affected by the last SQL statement.

(define (changes)
	(if db (sqlite3_changes db)))



;; @syntax (sql3:timeout <num-milli-seconds>)
;; @return 'true' on success or 'nil' on failure.
;; Sets busy timeout in milliseconds.

(define (timeout ms)
	(if db (zero? (sqlite3_busy_timeout db (int ms)))))



;; @syntax (sql3:error)
;; @return The error text of the last error occured in 'sql3:sql'.

(define (error) error-message)
	
(define (set-error)
	(set 'result (sqlite3_errmsg db))
	(if (= result 0) 
		(set 'error-message nil)
		(set 'error-message (get-string result))
		nil
	)
)


(context 'MAIN)

; -------------------------------------------------------------------------
;
; test the database routines
;
; if there is an old "SQLITE3-TEST" db from an earlier sqlite 2.8 delete it first
;
(define (test-sqlite3)
	(if (sql3:open "SQLITE3-TEST") 
		(println "database opened/created,  ... Ok")
		(println "problem opening/creating database"))

	(if (sql3:sql "create table fruits (name CHAR(20), qty INT(3), price FLOAT(10), blobtext BLOB);")
		(println "created table fruits,  ... Ok")
		(println "problem creating table fruits"))

	(if (sql3:sql "insert into fruits values ('apples', 11, 1.234, X'41424300010101');")
		(println "inserted, last row id: " (sql3:rowid) ",  ... Ok")
		(println "problem inserting row"))

	(if (sql3:sql "insert into fruits values ('oranges', 22, 2.345, X'42434400020202');")
		(println "inserted, last row id: " (sql3:rowid) ",  ... Ok")
		(println "problem inserting row"))

	(if (sql3:sql "insert into fruits values ('bananas', 33, 3.456, X'44454600030303');")
		(println "inserted, last row id: " (sql3:rowid) ",  ... Ok")
		(println "problem inserting row"))

	; Definition of a small helper function for the tests to emulate the X'...' argument
	; quoting of SQL

	(define (hexstring hexstr)
		(join (map (fn (s) (pack "c" (int s 0 16))) (find-all ".." hexstr))))

	; Following statement was modified below to show, how to use host variables with
	; the SQL INSERT statement.
	;	(if (sql3:sql "insert into fruits values (:name, :qty, :price, X'47484900040404');" 
	;        '((":name" "grapes") (":qty" 123456789012345678) (":price" 7,89)))
	;		(println "inserted, last row id: " (sql3:rowid) ",  ... Ok")
	;		(println "problem inserting row"))

	(if (sql3:sql "insert into fruits values (?, ?, ?, ?);" 
        		(list "grapes" 123456789012345678 (div 789 100) (hexstring "47484900040404")))
		(println "inserted, last row id: " (sql3:rowid) ",  ... Ok")
		(println "problem inserting row: " (sql3:error)))

	(set 'sqarray (sql3:sql "select * from fruits;"))

	(if sqarray
		(begin
			(println "selected rows: ") 
			(map println sqarray)
			(println "column names with sql3:col-names: ")
			(map println (sql3:colnames))
			(println "... Ok")
		)
		(println "problem with select"))

  	(if (= (sql3:sql "select name from fruits where qty < ? order by name;" '(33))
   		 	'(("apples") ("oranges")))
    		(println "select via host parameter (type '?'), ... Ok")
		(println "problem with selecting via host parameters (type '?')"))

  	(if (= (sql3:sql "select name from fruits where qty < :qty order by name;" '((":qty" 33)))
   		 	'(("apples") ("oranges")))
    		(println "select via host parameter (type ':VVV'), ... Ok")
		(println "problem with selecting via host parameters (type ':VVV')"))

  	(if (= (sql3:sql "select name from fruits where qty < ?2 order by name;" '(("?2" 33)))
   		 	'(("apples") ("oranges")))
    		(println "select via host parameter (type '?NNN'), ... Ok")
		(println "problem with selecting via host parameters (type '?NNN')"))

  	(if (= (sql3:sql "select name from fruits where qty < @par order by name;" '(("@par" 33)))
   		 	'(("apples") ("oranges")))
    		(println "select via host parameter (type '@VVV'), ... Ok")
		(println "problem with selecting via host parameters (type '@VVV')"))

  	(if (= (sql3:sql "select name from fruits where qty < $par order by name;" '(("$par" 33)))
   	 		'(("apples") ("oranges")))
    		(println "select via host parameter (type '$VVV'), ... Ok")
		(println "problem with selecting via host parameters (type '$VVV')"))


  	; SQL injection has no chance:
	
  	(print "try to drop table fruits via SQL injection attack ... ") 

  	(if (sql3:sql "select * from fruits where name = ?;" '("''; drop table fruits;"))
		(println "OUCH! Table was dropped via SQL injection!!!")
		(println "no luck, table was safe against SQL injection."))
	
	(if (sql3:sql "delete from fruits where 1;")
		(println "deleted, rows affected: " (sql3:changes) ",  ... Ok")
		(println "problem deleting rows"))

	(if (list? (sql3:tables) )
		(println "tables: " (sql3:tables) ", ... Ok")
		(println "problem in sql3:tables"))

	(if (list? (sql3:columns "fruits") )
		(println "columns: " (sql3:columns "fruits") ", ... Ok")
		(println "problem in sql3:columns"))

	(if (sql3 "drop table fruits;")
		(println "table fruits dropped,  ... Ok")
		(println "problem dropping table fruits"))

	(sql3:close)
)

; eof ;