Re: Re: DataObject_FormBuilder links

On Tue, Oct 19, 2004 at 09:55:23AM +0200, Alexander Petri wrote: > I also got such problems if i tried first... > first i guessed that DataObjects generates the *.links.ini file by himself > it doesnt, but the api documentation suggested it to me... I didn't think it auto-generated that. I wrote about 40 lines of guile script to do build the link file for me, attached just for anyone's amusement. Sorry it's not in PHP; right now I can do this kind of stuff faster in guile. The script uses functions from the attached kenlib file and the http://guile-simplesql.sourceforge.net package. My primary keys are all uniquely named "tablename_id" which made this task easier. I pasted the output of this script into my database.links.ini file, and I was done. Once I get to know DataObject and OOP better, I might try to rewrite this in PHP instead. Come to think of it, it might be nice to have this functionality in createTables.php. -ken -- --------------- The world's most affordable web hosting. http://www.nearlyfreespeech.net

;; $Id: build-links.scm,v 1.4 2004/10/19 21:29:49 ken Exp $ ;; Copyright (C) 2004 ken restivo <ken@restivo.org> ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;; builds a links file suitable for use by dataobject ;;; [table_name] ;;; column_name = primary_table.column_name ;; this of course assumes you name your primary keys uniquelyx ;; (load "/mnt/kens/ki/is/scheme/lib/build-links.scm") (use-modules (ice-9 slib) (database simplesql) (kenlib)) (require 'printf) ;;;;;;;; FUNCS ;; returns list of tables in db, with header filtered out (define (get-tables dbh) (cdr (map (lambda (x) (vector-ref x 0)) (simplesql-query dbh "show tables")))) ;; returns list of col names (define (get-columns dbh table) (simplesql-query dbh (string-append "explain " table))) ;; gets the primary key out of a list-of-vectors from "explain" query (define (get-primary-key explain-lov) (vector-ref (get-db-row 3 "PRI" explain-lov) 0)) ;; alist (key . table) (define (make-keys-tables-alist dbh tables) (map (lambda (table) (cons (get-primary-key (get-columns dbh table)) table)) (cdr tables))) ; cdr to eliminate title row ;; outputs the list of links, in format wanted by dbobject.links.ini (define (print-links dbh primary-keys check-table) (printf "\n[%s]\n" check-table) (for-each (lambda (column-name) (let* ((home-table (assoc-ref primary-keys column-name))) (if home-table (if (not (equal? home-table check-table)) (printf "%s = %s:%s\n" column-name home-table column-name))))) (map (lambda (x) (vector-ref x 0)) (get-columns dbh check-table)))) ;; this is the engine! output the thing! (define (output-links-list dbh) (for-each (lambda (table) (print-links dbh (make-keys-tables-alist dbh (get-tables *dbh*)) table)) (get-tables dbh))) ;;;;;;;;; ;; ok, do stuff (define (do-links-list) (let((dbh (apply simplesql-open "mysql" (read-conf "/mnt/kens/ki/proj/coop/sql/db-input.conf")))) (output-links-list dbh) (simplesql-close dbh))) ;; EOF;; $Id: kenlib.scm,v 1.50 2004/10/16 20:57:15 ken Exp $ ;; Copyright (C) 2004 ken restivo <ken@restivo.org> ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;; ken's library functions! ;; annoying guile. if you want to reload this, it has to be: ;; (load "/mnt/kens/ki/is/scheme/lib/kenlib.scm") ;; TODO: figure out how to make this a proper guile library! ;; also, how to make it work with skij etc. (define-module (kenlib) :export (for-each-vector split-string rev-vector-ref last-item pp src doit add-new-column last-insert-id pquery chomp read-conf add-sub-alist join-strings safe-sql parse-csv find-head safe-list-head between safe-string-trim list-position vector-position db-ref db-ref-last y2k-ify human-to-sql-date list-to-tab-delim assure-ending-nl debug-on debug-off debug-get get-db-row strip-duplicates list-to-pair directories-only plain-files directory-files slice-results un-null sql-quote make-like-line make-set-line get-db-name)) ;; stuff i'll always want to have present (use-modules (ice-9 debug) (ice-9 session) (ice-9 slib) (ice-9 string-fun) (database simplesql) (srfi srfi-1) (ice-9 debugger) (srfi srfi-2) (srfi srfi-13) (srfi srfi-14) (ice-9 format) (ice-9 regex)) ;;; natsty conditionals for 1.6 (require 'printf) (require 'pretty-print) ;; for-each-vector ;; like foreach, cycles through a vector vec, doing procedure. ;; if use-number, pass the procedure the vector's index ;; instead of the vector's object ;; returns NOTHING! just does side-effects on the thing. (define (for-each-vector procedure vec use-number) (do ;; variable, init, step (basically, a let) ((i 1 (+ 1 i))) ;; test, expression ((>= i (vector-length vec))) ;; command (procedure (if use-number i (vector-ref vec i))))) ;; lifted shamelessly from gnucash. this is basically ice-9 string-fun string-split (define (split-string str char) (let ((parts '()) (first-char #f)) (let loop ((last-char (string-length str))) (set! first-char (string-rindex str char 0 last-char)) (if first-char (begin (set! parts (cons (substring str (+ 1 first-char) last-char) parts)) (loop first-char)) (set! parts (cons (substring str 0 last-char) parts)))) parts)) ;;; jsut yer basic vector-ref, but with the args in the order i like 'em (define (rev-vector-ref index vec) (vector-ref vec index)) ;; get the last item in a list of vectors (i.e. returned by simplesql) (define (last-item queryresult) (vector-ref (cadr queryresult) 0)) ;;;; last-insert-id ;;; gets last insert id, from squile (define (last-insert-id dbh) (let ((res (safe-sql dbh "select last_insert_id()"))) (if (list? res) (last-item res) #f))) ;;; (define (make-index result) ;;; TODO do this! nil ) ;; utility. save carpool tunnel syndrome. (define (pquery dbh query) (pretty-print (simplesql-query dbh query))) (define pp pretty-print) (define (src x) (pretty-print (source x))) (require 'line-i/o) (require 'common-list-functions) ;; from a linuxjournal article (define (lineterm? ch) (case ch ((#\newline #\return) #t) (else #f))) ;; it is absolutely UNPOSSIBLE for me to live without this ;; use string-trim or string-trim-both in srfi-13 instead (define (chomp string) (list->string (remove-if lineterm? (string->list string)))) ; handle my strange little conf file format! ;; XXX this implementation sucks. if there are any stray lines, ;; TODO: re-do this to use string-tokenize ;;; this will return NULL list (define (read-conf filename) (let ((p (open-input-file filename ) ) (saveline '())) (begin (do ((line (read-line p) (read-line p))) ((or (eof-object? line) (not (null? saveline)))) ((lambda (x) (if (< 3 (length x)) (set! saveline x) ;;(pp x) )) (string-split line #\tab))) (close p) saveline))) ;; utility to add an alist to an alist of alists! it works for sub-data ;; so, index is the TOP level alist entry. key is the sub-level ;; i.e. (add-sub-alist *schema* "tablename" "columnname" "spec) ;; result will be alist of alists ("tablename" ("columnmane" . "spec")) (define (add-sub-alist list index key data) (let* ((tmp (assoc-ref list index))) (assoc-set! list index ; set!'s the ASSOC, returns the alist (if tmp ; create it if it doesn't exist (assoc-set! tmp key data) (acons key data '()))))) ;; TODO look for string-join, it already exists somwehere! (define (join-strings s) (cond ((null? s) "") ((null? (cdr s)) (car s)) (else (string-append (car s) " " (join-strings (cdr s)))))) ;; nice little abstraction to make a new column and add a default ;; update only if i'm creating a new column successfully- avoid data corruption (define (add-new-column dbh table column-name definition default) (if (list? (safe-sql dbh (sprintf #f "alter table %s add column %s %s" table column-name definition))) (if default (safe-sql dbh (sprintf #f "update %s set %s = '%s'" table column-name default))))) ;; parsing csv data (define parse-csv (let* ((csv-match (string-join '("\"([^\"\\\\]*(\\\\.[^\"\\\\]*)*)\",?" "([^,]+),?" ",") "|")) (csv-rx (make-regexp csv-match))) (lambda (text) (let ((start 0) (result '())) (let loop ((start 0)) (and-let* ((m (regexp-exec csv-rx text start))) (set! result (cons (or (match:substring m 1) (match:substring m 3)) result)) (loop (match:end m)))) (reverse result))))) ;;; based on shivers srfi stuff (define (take-up-to pred l) (let ((end-pos (list-index pred l))) (if end-pos (take l end-pos) l))) ;; returns the items in between start and end ;; where start and end are matched with equal? and member? (which uses equal?) (define (between start end list) (let ((top-filtered (member start list))) (if top-filtered (take-up-to (lambda (x) (equal? x end)) (cdr top-filtered)) (throw 'not-found start )))) (define (safe-list-head list len) (if (> (length list) len) (list-head list len) list)) (define (safe-string-trim string) (if (string? string) (string-trim-both string) string)) ;; silly little diagnostic, WITH safety valve ;; which is actually false-if-exception, with weird other shit too (define debug? #t) (define (debug-on) (set! debug? #t)) (define (debug-off) (set! debug? #f)) (define (debug-get) debug?) (define (safe-sql dbh query) (if debug? (begin (write-line (string-delete query (char-set #\tab #\newline))) #t) ;return true if i'm just debuggin' (catch #t (lambda () (simplesql-query dbh query) ) (lambda x (printf "caught error on [%s]\n" query) (pp x) #f)))) ;; find position in list matching key (define (list-position key list) (letrec ((loop (lambda (i list) (if (null? list) #f (if (equal? (car list) key) i (loop (+ i 1) (cdr list))))))) (loop 0 list))) ;; retrieve idx'th item in list. my own silly version of srfi list-ref (define (list-ref-kr idx list) (let loop ((i (length list)) (l list)) (if (null? l) #f (if (= i idx) (car (last-pair l)) (loop (- i 1) (list-head l (+ idx 1))) )))) ;; a very generic function, for finding vector positions (define (vector-position key vec) (let lp ((x (- (vector-length vec) 1))) (if (equal? key (vector-ref vec x)) x (if (positive? x) (lp (- x 1)) #f)))) ;; grabs from this line (define (db-ref key header-vector data-vector) (let ((key-pos (vector-position key header-vector))) (vector-ref data-vector key-pos))) ;;NOTE! this shorthands grabs the LAST vector in a list of vectors! ;;this assumes a list with a header in the car and the data in the cadr (define (db-ref-last list-of-vectors key) (db-ref key (car list-of-vectors) (car (last-pair list-of-vectors)))) ;not cadr, case > 2 ;; should this really be necessary? i think not. but, it is. (define (y2k-ify y) (cond ((not (number? y)) #f) ((< y 50) (+ y 2000)) ((< y 1000) (+ y 1900) ) (else y))) ;; convert regular american-style date to an sql-proper date (define (human-to-sql-date date) (let ((sm (string-match "^([0-9]+)/([0-9]+)/([0-9]+)" date))) (if sm (sprintf #f "%04d-%02d-%02d" (y2k-ify (string->number (match:substring sm 3))) (match:substring sm 1) (match:substring sm 2)) #f))) ;; ack. make this accept a PORT. a string or file port (define (list-to-tab-delim list port) (for-each (lambda (line-as-list-or-vector) (let ((line-as-list (if (vector? line-as-list-or-vector) (vector->list line-as-list-or-vector) line-as-list-or-vector))) (display (string-append (string-join (map (lambda (item) (cond ((and (list? item) (null? item)) "") ((not item) "") ((number? item) (number->string item)) (else item))) line-as-list) "\t") "\n") port))) list)) ;; returns the vector from a db list of vectors, where the string ;; representation of the index matches that supplied (define (get-db-row index-position row-index-string list-of-vectors) (let loop ( (lst list-of-vectors)) (cond ((null? lst) #f) ((equal? row-index-string (vector-ref (car lst) index-position)) (car lst)) (else (loop (cdr lst)))))) ;; front end to get-db-row (define (get-db-name index-name row-index-string list-of-vectors) ;; TODO: i don't feel like fucking with this right now ) (define (assure-ending-nl line) (if (string-rindex line #\nl) line (sprintf #f "%s\n" line))) ;; from john david stone, grin.edu example (define strip-duplicates (lambda (ls) (let loop ((rest ls) (so-far '())) (if (null? rest) so-far (loop (cdr rest) (let ((first (car rest))) (if (member first (cdr rest)) so-far (cons first so-far)))))))) ;; takes a 2-item list and returns a cons pair (define (list-to-pair list) (map (lambda (x) (cons (car x) (cadr x))) list)) ;;; from the perl book (define (directory-files dir) (if (not (access? dir R_OK)) '() (let ((p (opendir dir))) (do ((file (readdir p) (readdir p)) (ls '())) ((eof-object? file) (closedir p) (reverse! ls)) (set! ls (cons file ls)))))) ;; also from perl boook (define plain-files (let ((rx (make-regexp "^\\."))) (lambda (dir) (sort (filter (lambda (x) (eq? 'regular (stat:type (stat x)))) (map (lambda (x) (string-append dir "/" x)) (remove (lambda (x) (regexp-exec rx x)) (cddr (directory-files dir))))) string<)))) ;; my custom variation for doing recursive files (define (directories-only dir) (if (not (access? dir R_OK)) '() (let ((p (opendir dir))) (do ((file (readdir p) (readdir p)) (ls '())) ((eof-object? file) (closedir p) (reverse! ls)) (if (equal? (stat:type (stat file)) 'directory) (set! ls (cons file ls))))))) ;; gets the first col of a sql database return set. ;; useful for things like explain tables (define (slice-results dbh col query) (map (lambda (x) (vector-ref x col)) (simplesql-query dbh query))) ;; converts a db-result vector to a list with nulls converted to "" (define (un-null vec) (map (lambda (x) (if (null? x) "" (sql-quote x #f))) (vector->list vec))) (define (sql-quote val like) (if (string? val) (if like (sprintf #f "\"%%%s%%\"" val) (sprintf #f "\"%s\"" val)) (number->string val) )) ;; make like line from list of ((col-name . value)) (define (make-like-line indexed-list) (string-join (map (lambda (x) (string-append (car x) " = " (cdr x) )) indexed-list) " and ")) (define (make-set-line indexed-list) (string-join (map (lambda (x) (string-append (car x) " = " (cdr x) )) indexed-list) " , ")) ;; EOF