too.l

A very small LISP implementation with several packages and demo programs.

         (when (isa '+Entity Obj)
            (unless (meta Obj 'dbf)
               (prin "### ")
               (println 'dbfCheck Obj (val Obj))) ) )
      '((Base Root Var Cls Hook)
         (when (and Var (not (get Cls Var 'dbf)))
            (prin "### ")
            (println 'dbfCheck Var Cls) ) ) ) )

(de dbfMigrate (Pool Dbs)
   (let
      (scan
         '(("Tree" "Foo")
            (let "Node" (cdr (root "Tree"))
               (if (ext? (fin (val "Node")))
                  (recur ("Node")
                     (let? "X" (val "Node")
                        (recurse (cadr "X"))
                        ("Foo" (car "X") (cdddr "X"))
                        (recurse (caddr "X"))
                        (wipe "Node") ) )
                  (recur ("Node")
                     (let? "X" (val "Node")
                        (recurse (car "X"))
                        (for "Y" (cdr "X")
                           ("Foo" (car "Y") (or (cddr "Y") (fin (car "Y"))))
                           (recurse (cadr "Y")) )
                        (wipe "Node") ) ) ) ) )
         iter
         '(("Tree" "Bar")
            (scan "Tree" '(("K" "V") ("Bar" "V"))) )
         zapTree
         '((Node)
            (let? X (val Node)
               (zapTree (cadr X))
               (zapTree (caddr X))
               (zap Node) ) ) )
      (dbfUpdate) )
   (let Lst
      (make
         (for (S *DB S (seq S))
            (link (cons S (val S) (getl S))) ) )
      (pool)
      (call 'rm (pack Pool 1))
      (pool Pool Dbs)
      (set *DB (cadar Lst))
      (putl *DB (cddr (pop 'Lst)))
      (for L Lst
         (let New (new T)
            (set New (cadr L))
            (putl New (cddr L))
            (con L New) ) )
      (set *DB (dbfReloc0 (val *DB) Lst))
      (for X Lst
         (set (cdr X) (dbfReloc0 (val (cdr X)) Lst))
         (putl (cdr X) (dbfReloc0 (getl (cdr X)) Lst)) )
      (commit)
      (dbMap  # Relocate base symbols
         '((Obj)
            (putl Obj (dbfReloc0 (getl Obj) Lst))
            (commit) )
         '((Base Root Var Cls Hook)
            (when (asoq (cdr Root) Lst)
               (con Root (cdr @))
               (touch Base)
               (commit) ) ) ) ) )

(de dbfUpdate ()
   (dbMap  # Move
      '((Obj)
         (let N (or (meta Obj 'dbf 1) 1)
            (unless (= N (car (id Obj T)))
               (let New (new N)
                  (set New (val Obj))
                  (putl New (getl Obj))
                  (set Obj (cons T New)) )
               (commit) ) ) ) )
   (when *Blob
      (for X
         (make
            (use (@S @R F S)
               (let Pat (conc (chop *Blob) '(@S "." @R))
                  (in (list 'find *Blob "-type" "f")
                     (while (setq F (line))
                        (and
                           (match Pat F)
                           (setq S (extern (pack (replace @S '/))))
                           (=T (car (pair (val S))))
                           (link
                              (cons (pack F) (blob (cdr (val S)) @R)) ) ) ) ) ) ) )
         (call 'mkdir "-p" (dirname (cdr X)))
         (call 'mv (car X) (cdr X)) ) )
   (dbMap  # Relocate
      '((Obj)
         (when (=T (car (pair (val Obj))))
            (setq Obj (cdr (val Obj))) )
         (when (isa '+Entity Obj)
            (putl Obj (dbfReloc (getl Obj)))
            (commit) ) )
      '((Base Root Var Cls Hook)
         (if Var
            (dbfRelocTree Base Root (tree Var Cls Hook) (get Cls Var 'dbf))
            (dbfRelocTree Base Root Base) ) ) )
   (dbgc) )

(de dbfReloc (X)
   (cond
      ((pair X)
         (cons (dbfReloc (car X)) (dbfReloc (cdr X))) )
      ((and (ext? X) (=T (car (pair (val X)))))
         (cdr (val X)) )
      (T X) ) )

(de dbfReloc0 (X Lst)
   (cond
      ((pair X)
         (cons (dbfReloc0 (car X) Lst) (dbfReloc0 (cdr X) Lst)) )
      ((asoq X Lst) (cdr @))
      (T X) ) )

(de dbfRelocTree (Base Root Tree Dbf)
   (let? Lst (make (scan Tree '((K V) (link (cons K V)))))
      (zapTree (cdr Root))
      (touch Base)
      (set Root 0)
      (con Root)
      (commit)
      (for X
         (make
            (for
               (Lst (cons Lst) Lst
                  (mapcan
                     '((L)
                        (let (N (/ (inc (length L)) 2)  X (nth L N))
                           (link (car X))
                           (make
                              (and (>= N 2) (link (head (dec N) L)))
                              (and (cdr X) (link @)) ) ) )
                     Lst ) ) ) )
         (store Tree
            (dbfReloc (car X))
            (dbfReloc (cdr X))
            Dbf ) )
      (commit) ) )


### DB Unload/Load ###
(de dbUnload (File N)
   (out File
      (for (S (seq N) S (seq S))
         (println (cons S (val S) (getl S))) ) ) )

(de dbLoad (File N)
   (in File
      (let (P (seq N)  F)
         (for (L (read) L (read))
            (setq F (seq P (setq P (car L)) F))
            (commit) ) ) )
   (in File
      (for (L (read) L (read))
         (set (car L) (cadr L))
         (putl (car L) (cddr L))
         (commit) ) ) )


### Dump Objects ###
(de dump CL
   (let B 0
      (for ("Q" (goal CL) (asoq '@@ (prove "Q")))
         (let (Obj (cdr @)  Lst)
            (prin "(obj ")
            (_dmp Obj)
            (maps
               '((X)
                  (unless (member X Lst)
                     (prinl)
                     (space 3)
                     (cond
                        ((pair X)
                           (printsp (cdr X))
                           (_dmp (car X) T) )
                        ((isa '+Blob (meta Obj X))
                           (prin X " `(tmp " (inc 'B) ")")
                           (out (tmp B)
                              (in (blob Obj X) (echo)) ) )
                        (T (print X T)) ) ) )
                  Obj )
            (prinl " )")
            Obj ) ) ) )

(de _dmp (Obj Flg)
   (cond
      ((pair Obj)
         (prin "(")
         (_dmp (pop 'Obj) T)
         (while (pair Obj)
            (space)
            (_dmp (pop 'Obj) T) )
         (when Obj
            (prin " . ")
            (_dmp Obj T) )
         (prin ")") )
      ((ext? Obj)
         (when Flg
            (prin "`(obj ") )
         (prin "(")
         (catch NIL
            (maps
               '((X)
                  (with (and (pair X) (meta Obj (cdr X)))
                     (when (isa '+Key This)
                        (or Flg (push 'Lst X))
                        (printsp (type Obj) (: var))
                        (when (: hook)
                           (_dmp (: hook) T)
                           (space) )
                        (_dmp (car X) T)
                        (throw) ) ) )
               Obj )
            (print (type Obj))
            (maps
               '((X)
                  (with (and (pair X) (meta Obj (cdr X)))
                     (when (isa '+Ref This)
                        (space)
                        (or Flg (push 'Lst X))
                        (print (: var))
                        (when (: hook)
                           (space)
                           (_dmp (: hook) T) )
                        (space)
                        (_dmp (car X) T) ) ) )
               Obj ) )
         (when Flg
            (prin ")") )
         (prin ")") )
      (T (print Obj)) ) )

`*Dbg
(noLint 'dbfMigrate 'iter)

# vi:et:ts=3:sw=3