too.l (17977B)
1 # 13jul13abu 2 # (c) Software Lab. Alexander Burger 3 4 ### Local Backup ### 5 (de snapshot (Dst . @) 6 (for (L (flip (sort (mapcar format (dir Dst)))) L) 7 (let N (pop 'L) 8 (call 'mv (pack Dst '/ N) (pack Dst '/ (inc N))) 9 (when (> (car L) (*/ N 9 10)) 10 (call 'rm "-rf" (pack Dst '/ (pop 'L))) ) ) ) 11 (when (call 'mkdir (pack Dst "/1")) 12 (while (args) 13 (let 14 (Lst (filter bool (split (chop (next)) '/)) 15 Src (car Lst) 16 Old (pack Dst "/2/" Src) 17 New (pack Dst "/1/" Src) ) 18 (recur (Lst Src Old New) 19 (ifn (cdr Lst) 20 (recur (Src Old New) 21 (cond 22 ((=T (car (info Src T))) # Directory 23 (call 'mkdir "-p" New) 24 (for F (dir Src T) 25 (unless (member F '("." "..")) 26 (recurse 27 (pack Src '/ F) 28 (pack Old '/ F) 29 (pack New '/ F) ) ) ) 30 (call 'touch "-r" Src New) ) 31 ((= (info Src T) (info Old T)) # Same 32 `(if (== 64 64) 33 '(native "@" "link" 'I Old New) 34 '(call 'ln Old New) ) ) 35 (T (call 'cp "-a" Src New)) ) ) # Changed or new 36 (call 'mkdir "-p" New) 37 (recurse 38 (cdr Lst) 39 (pack Src '/ (cadr Lst)) 40 (pack Old '/ (cadr Lst)) 41 (pack New '/ (cadr Lst)) ) 42 (call 'touch "-r" Src New) ) ) ) ) ) ) 43 44 ### DB Garbage Collection ### 45 (de dbgc () 46 (markExt *DB) 47 (let Cnt 0 48 (finally (mark 0) 49 (for (F . @) (or *Dbs (2)) 50 (for (S (seq F) S (seq S)) 51 (unless (mark S) 52 (inc 'Cnt) 53 (and (isa '+Entity S) (zap> S)) 54 (zap S) ) ) ) ) 55 (commit) 56 (when *Blob 57 (use (@S @R F S) 58 (let Pat (conc (chop *Blob) '(@S "." @R)) 59 (in (list 'find *Blob "-type" "f") 60 (while (setq F (line)) 61 (when (match Pat F) 62 (unless 63 (and 64 (setq S (extern (pack (replace @S '/)))) 65 (get S (intern (pack @R))) ) 66 (inc 'Cnt) 67 (call 'rm (pack F)) ) 68 (wipe S) ) ) ) ) ) ) 69 (gt0 Cnt) ) ) 70 71 (de markExt (S) 72 (unless (mark S T) 73 (markData (val S)) 74 (maps markData S) 75 (wipe S) ) ) 76 77 (de markData (X) 78 (while (pair X) 79 (markData (pop 'X)) ) 80 (and (ext? X) (markExt X)) ) 81 82 ### DB Mapping ### 83 (de dbMap ("ObjFun" "TreeFun") 84 (default "ObjFun" quote "TreeFun" quote) 85 (finally (mark 0) 86 (_dbMap *DB) 87 (dbMapT *DB) ) ) 88 89 (de _dbMap ("Hook") 90 (unless (mark "Hook" T) 91 ("ObjFun" "Hook") 92 (for "X" (getl "Hook") 93 (when (pair "X") 94 (if 95 (and 96 (ext? (car "X")) 97 (not (isa '+Entity (car "X"))) 98 (sym? (cdr "X")) 99 (find 100 '(("X") (isa '+relation (car "X"))) 101 (getl (cdr "X")) ) ) 102 (let ("Base" (car "X") "Cls" (cdr "X")) 103 (dbMapT "Base") 104 (for "X" (getl "Base") 105 (when 106 (and 107 (pair "X") 108 (sym? (cdr "X")) 109 (pair (car "X")) 110 (num? (caar "X")) 111 (ext? (cdar "X")) ) 112 ("TreeFun" "Base" (car "X") (cdr "X") "Cls" "Hook") 113 (iter (tree (cdr "X") "Cls" "Hook") _dbMap) ) ) 114 (wipe "Base") ) 115 (dbMapV (car "X")) ) ) ) 116 (wipe "Hook") ) ) 117 118 (de dbMapT ("Base") 119 (let "X" (val "Base") 120 (when 121 (and 122 (pair "X") 123 (num? (car "X")) 124 (ext? (cdr "X")) ) 125 ("TreeFun" "Base" "X") 126 (iter "Base" dbMapV) ) ) ) 127 128 (de dbMapV ("X") 129 (while (pair "X") 130 (dbMapV (pop '"X")) ) 131 (and (ext? "X") (_dbMap "X")) ) 132 133 ### DB Check ### 134 (de dbCheck () 135 (and (lock) (quit 'lock @)) # Lock whole database 136 (for (F . N) (or *Dbs (2)) # Low-level integrity check 137 (unless (pair (println F N (dbck F T))) 138 (quit 'dbck @) ) ) 139 (dbMap # Check tree structures 140 NIL 141 '((Base Root Var Cls Hook) 142 (println Base Root Var Cls Hook) 143 (unless (= (car Root) (chkTree (cdr Root))) 144 (quit "Tree size mismatch") ) 145 (when Var 146 (scan (tree Var Cls Hook) 147 '((K V) 148 (or 149 (isa Cls V) 150 (isa '+Alt (meta V Var)) 151 (quit "Bad Type" V) ) 152 (unless (has> V Var (if (pair K) (car K) K)) 153 (quit "Bad Value" K) ) ) 154 NIL T T ) ) ) ) 155 (and *Dbs (dbfCheck)) # Check DB file assignments 156 (and (dangling) (println 'dangling @)) # Show dangling index references 157 T ) 158 159 (de dangling () 160 (make 161 (dbMap 162 '((This) 163 (and 164 (not (: T)) 165 (dangle This) 166 (link @) ) ) ) ) ) 167 168 # Check Index References 169 (de dangle (Obj) 170 (and 171 (make 172 (for X (getl Obj) 173 (let V (or (atom X) (pop 'X)) 174 (with (meta Obj X) 175 (cond 176 ((isa '+Joint This) 177 (if (isa '+List This) 178 (when 179 (find 180 '((Y) 181 (if (atom (setq Y (get Y (: slot)))) 182 (n== Obj Y) 183 (not (memq Obj Y)) ) ) 184 V ) 185 (link X) ) 186 (let Y (get V (: slot)) 187 (if (atom Y) 188 (unless (== Obj Y) (link X)) 189 (unless (memq Obj Y) (link X)) ) ) ) ) 190 ((isa '+Key This) 191 (and 192 (<> Obj 193 (fetch 194 (tree X (: cls) (get Obj (: hook))) 195 V ) ) 196 (link X) ) ) 197 ((isa '+Ref This) 198 (let 199 (Tree (tree X (: cls) (get Obj (: hook))) 200 Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) ) 201 (if (isa '+List This) 202 (when 203 (find 204 '((Y) 205 (and 206 (or 207 (not (isa '+Fold This)) 208 (setq V (fold V)) ) 209 (<> Obj (fetch Tree (cons Y Aux))) ) ) 210 V ) 211 (link X) ) 212 (and 213 (or 214 (not (isa '+Fold This)) 215 (setq V (fold V)) ) 216 (<> Obj (fetch Tree (cons V Aux))) 217 (link X) ) ) ) ) 218 (T 219 (for (N . B) (: bag) 220 (cond 221 ((isa '+Key B) 222 (with B 223 (when 224 (find 225 '((L) 226 (let? Val (get L N) 227 (<> Obj 228 (fetch 229 (tree (: var) (: cls) 230 (get 231 (if (sym? (: hook)) Obj L) 232 (: hook) ) ) 233 Val ) ) ) ) 234 V ) 235 (link X) ) ) ) 236 ((isa '+Ref B) 237 (with B 238 (when 239 (find 240 '((L) 241 (let? Val (get L N) 242 (when (isa '+Fold This) 243 (setq Val (fold Val)) ) 244 (<> Obj 245 (fetch 246 (tree (: var) (: cls) 247 (get 248 (if (sym? (: hook)) Obj L) 249 (: hook) ) ) 250 (cons Val Obj) ) ) ) ) 251 V ) 252 (link X) ) ) ) ) ) ) ) ) ) ) ) 253 (cons Obj @) ) ) 254 255 ### Rebuild tree ### 256 (de rebuild (X Var Cls Hook) 257 (let Lst NIL 258 (let? Base (get (or Hook *DB) Cls) 259 (unless X 260 (setq Lst 261 (if (; (treeRel Var Cls) hook) 262 (collect Var Cls Hook) 263 (collect Var Cls) ) ) ) 264 (zapTree (get Base Var -1)) 265 (put Base Var NIL) 266 (commit) ) 267 (nond 268 (X 269 (let Len (length Lst) 270 (recur (Lst Len) 271 (unless (=0 Len) 272 (let (N (>> 1 (inc Len)) L (nth Lst N)) 273 (re-index (car L) Var Hook) 274 (recurse Lst (dec N)) 275 (recurse (cdr L) (- Len N)) ) ) ) ) ) 276 ((atom X) 277 (for Obj X 278 (re-index Obj Var Hook) ) ) 279 (NIL 280 (for (Obj X Obj (seq Obj)) 281 (and (isa Cls Obj) (re-index Obj Var Hook)) ) ) ) 282 (commit) ) ) 283 284 (de re-index (Obj Var Hook) 285 (unless (get Obj T) 286 (when (get Obj Var) 287 (rel> (meta Obj Var) Obj NIL 288 (put> (meta Obj Var) Obj NIL @) 289 Hook ) 290 (at (0 . 10000) (commit)) ) ) ) 291 292 ### Database file management ### 293 (de dbfCheck () 294 (for "Cls" (all) 295 (when (and (= `(char "+") (char "Cls")) (isa '+Entity "Cls")) 296 (or 297 (get "Cls" 'Dbf) 298 (meta "Cls" 'Dbf) 299 (println 'dbfCheck "Cls") ) 300 (for Rel (getl "Cls") 301 (and 302 (pair Rel) 303 (or 304 (isa '+index (car Rel)) 305 (find '((B) (isa '+index B)) (; Rel 1 bag)) ) 306 (unless (; Rel 1 dbf) 307 (println 'dbfCheck (cdr Rel) "Cls") ) ) ) ) ) ) 308 309 (de dbfMigrate (Pool Dbs) 310 (let 311 (scan 312 '(("Tree" "Fun") 313 (let "Node" (cdr (root "Tree")) 314 (if (ext? (fin (val "Node"))) 315 (recur ("Node") 316 (let? "X" (val "Node") 317 (recurse (cadr "X")) 318 ("Fun" (car "X") (cdddr "X")) 319 (recurse (caddr "X")) 320 (wipe "Node") ) ) 321 (recur ("Node") 322 (let? "X" (val "Node") 323 (recurse (car "X")) 324 (for "Y" (cdr "X") 325 ("Fun" (car "Y") (or (cddr "Y") (fin (car "Y")))) 326 (recurse (cadr "Y")) ) 327 (wipe "Node") ) ) ) ) ) 328 iter 329 '(("Tree" "Bar") 330 (scan "Tree" '(("K" "V") ("Bar" "V"))) ) 331 zapTree 332 '((Node) 333 (let? X (val Node) 334 (zapTree (cadr X)) 335 (zapTree (caddr X)) 336 (zap Node) ) ) ) 337 (dbfUpdate) ) 338 (let Lst 339 (make 340 (for (S *DB S (seq S)) 341 (link (cons S (val S) (getl S))) ) ) 342 (pool) 343 (call 'rm (pack Pool 1)) 344 (pool Pool Dbs) 345 (set *DB (cadar Lst)) 346 (putl *DB (cddr (pop 'Lst))) 347 (for L Lst 348 (let New (new T) 349 (set New (cadr L)) 350 (putl New (cddr L)) 351 (con L New) ) ) 352 (set *DB (dbfReloc0 (val *DB) Lst)) 353 (for X Lst 354 (set (cdr X) (dbfReloc0 (val (cdr X)) Lst)) 355 (putl (cdr X) (dbfReloc0 (getl (cdr X)) Lst)) ) 356 (commit) 357 (dbMap # Relocate base symbols 358 '((Obj) 359 (putl Obj (dbfReloc0 (getl Obj) Lst)) 360 (commit) ) 361 '((Base Root Var Cls Hook) 362 (when (asoq (cdr Root) Lst) 363 (con Root (cdr @)) 364 (touch Base) 365 (commit) ) ) ) ) ) 366 367 (de dbfUpdate () 368 (dbMap # Move 369 '((Obj) 370 (let N (or (meta Obj 'Dbf 1) 1) 371 (unless (= N (car (id Obj T))) 372 (let New (new N) 373 (set New (val Obj)) 374 (putl New (getl Obj)) 375 (set Obj (cons T New)) ) 376 (commit) ) ) ) ) 377 (when *Blob 378 (for X 379 (make 380 (use (@S @R F S) 381 (let Pat (conc (chop *Blob) '(@S "." @R)) 382 (in (list 'find *Blob "-type" "f") 383 (while (setq F (line)) 384 (and 385 (match Pat F) 386 (setq S (extern (pack (replace @S '/)))) 387 (=T (car (pair (val S)))) 388 (link 389 (cons (pack F) (blob (cdr (val S)) @R)) ) ) ) ) ) ) ) 390 (and (dirname (cdr X)) (call 'mkdir "-p" @)) 391 (call 'mv (car X) (cdr X)) ) ) 392 (dbMap # Relocate 393 '((Obj) 394 (when (=T (car (pair (val Obj)))) 395 (setq Obj (cdr (val Obj))) ) 396 (when (isa '+Entity Obj) 397 (putl Obj (dbfReloc (getl Obj))) 398 (commit) ) ) 399 '((Base Root Var Cls Hook) 400 (if Var 401 (dbfRelocTree Base Root (tree Var Cls Hook) (get Cls Var 'dbf)) 402 (dbfRelocTree Base Root Base) ) ) ) 403 (dbgc) ) 404 405 (de dbfReloc (X) 406 (cond 407 ((pair X) 408 (cons (dbfReloc (car X)) (dbfReloc (cdr X))) ) 409 ((and (ext? X) (=T (car (pair (val X))))) 410 (cdr (val X)) ) 411 (T X) ) ) 412 413 (de dbfReloc0 (X Lst) 414 (cond 415 ((pair X) 416 (cons (dbfReloc0 (car X) Lst) (dbfReloc0 (cdr X) Lst)) ) 417 ((asoq X Lst) (cdr @)) 418 (T X) ) ) 419 420 (de dbfRelocTree (Base Root Tree Dbf) 421 (let? Lst (make (scan Tree '((K V) (link (cons K V))))) 422 (zapTree (cdr Root)) 423 (touch Base) 424 (set Root 0) 425 (con Root) 426 (commit) 427 (for X 428 (make 429 (for 430 (Lst (cons Lst) Lst 431 (mapcan 432 '((L) 433 (let (N (/ (inc (length L)) 2) X (nth L N)) 434 (link (car X)) 435 (make 436 (and (>= N 2) (link (head (dec N) L))) 437 (and (cdr X) (link @)) ) ) ) 438 Lst ) ) ) ) 439 (store Tree 440 (dbfReloc (car X)) 441 (dbfReloc (cdr X)) 442 Dbf ) ) 443 (commit) ) ) 444 445 ### Dump Objects ### 446 (de dump CL 447 (let B 0 448 (for ("Q" (goal CL) (asoq '@@ (prove "Q"))) 449 (let (Obj (cdr @) Lst) 450 (prin "(obj ") 451 (_dmp Obj) 452 (maps 453 '((X) 454 (unless (or (member X Lst) (= `(char "+") (char (fin X)))) 455 (prinl) 456 (space 3) 457 (cond 458 ((pair X) 459 (printsp (cdr X)) 460 (_dmp (car X) T) ) 461 ((isa '+Blob (meta Obj X)) 462 (prin X " `(tmp " (inc 'B) ")") 463 (out (tmp B) 464 (in (blob Obj X) (echo)) ) ) 465 (T (print X T)) ) ) ) 466 Obj ) 467 (prinl " )") 468 Obj ) ) ) ) 469 470 (de _dmp (Obj Flg) 471 (cond 472 ((pair Obj) 473 (prin "(") 474 (_dmp (pop 'Obj) T) 475 (while (pair Obj) 476 (space) 477 (_dmp (pop 'Obj) T) ) 478 (when Obj 479 (prin " . ") 480 (_dmp Obj T) ) 481 (prin ")") ) 482 ((ext? Obj) 483 (when Flg 484 (prin "`(obj ") ) 485 (prin "(") 486 (catch NIL 487 (maps 488 '((X) 489 (with (and (pair X) (meta Obj (cdr X))) 490 (when (isa '+Key This) 491 (or Flg (push 'Lst X)) 492 (printsp (type Obj) (: var)) 493 (_dmp (car X) T) 494 (throw) ) ) ) 495 Obj ) 496 (print (type Obj)) 497 (maps 498 '((X) 499 (with (and (pair X) (meta Obj (cdr X))) 500 (when (isa '+Ref This) 501 (space) 502 (or Flg (push 'Lst X)) 503 (print (: var)) 504 (space) 505 (_dmp (car X) T) ) ) ) 506 Obj ) ) 507 (when Flg 508 (prin ")") ) 509 (prin ")") ) 510 (T (print Obj)) ) ) 511 512 ### Debug ### 513 `*Dbg 514 (noLint 'dbfMigrate 'iter) 515 516 # vi:et:ts=3:sw=3