form.l (49511B)
1 # 28may13abu 2 # (c) Software Lab. Alexander Burger 3 4 # *PRG *Top *Gui *Btn *Get *Got *Form *Evt *Lock *Spans 5 # "*Cnt" "*Lst" "*App" "*Err" "*Foc" "*Post2" "*Stat" "*Ix" "*Chart" "*Cho" 6 7 (allow "@img/" T) 8 (push1 '*JS (allow "@lib/form.js")) 9 (mapc allow 10 (quote 11 *Gui *Get *Got *Form "!jsForm" *Evt *Drop 12 *JsHint "!jsHint" *JsArgs "!tzOffs" ) ) 13 14 (one "*Cnt") 15 (off "*Lst" "*Post2" "*Cho" "*TZO") 16 17 (de *Throbber 18 ("+---" "-+--" "--+-" "---+" "--+-" "-+--" .) ) 19 20 (de tzOffs (Min) 21 (setq "*TZO" (* Min 60)) ) 22 23 # Define GUI form 24 (de form ("Attr" . "Prg") 25 (inc '*Form) 26 (let "App" 27 (if *PRG 28 (get "*Lst" (- "*Cnt" *Get) *Form) 29 (prog1 (setq *Top (new NIL NIL 'able T 'evt 0)) 30 (queue (nth "*Lst" (- "*Cnt" *Get)) *Top) ) ) 31 (let "Lst" (get "*Lst" (- "*Cnt" *Get) 1) 32 (for ("F" . "L") "Lst" 33 (let *Form (- "F" (length "Lst")) 34 (cond 35 ((and (== *PRG (car "L")) (memq "App" (get *PRG 'top))) 36 (apply "form" "L") ) 37 ((or (== *PRG "App") (memq "App" (get *PRG 'top))) 38 (if (get "L" 1 'top) 39 (apply "form" "L") 40 (put (car "L") 'top (cons *PRG (get *PRG 'top))) 41 (let *PRG NIL (apply "form" "L")) ) ) ) ) ) ) 42 ("form" "App" "Attr" "Prg") ) ) 43 44 (de "form" ("*App" "Attr" "Prg") 45 (with "*App" 46 (job (: env) 47 (<post> "Attr" (urlMT *Url *Menu *Tab *ID) 48 (<hidden> '*Get *Get) 49 (<hidden> '*Form *Form) 50 (<hidden> '*Evt (: evt)) 51 (zero "*Ix") 52 (off "*Chart") 53 (if *PRG 54 (let gui 55 '(() 56 (with (get "*App" 'gui (inc '"*Ix")) 57 (for E "*Err" 58 (when (== This (car E)) 59 (<div> 'error 60 (if (atom (cdr E)) 61 (ht:Prin (eval (cdr E) 1)) 62 (eval (cdr E) 1) ) ) ) ) 63 (if (: id) 64 (let *Gui (val "*App") 65 (show> This (cons '*Gui @)) ) 66 (setq "*Chart" This) ) 67 This ) ) 68 (and (== *PRG "*App") (setq *Top "*App")) 69 (htPrin "Prg") ) 70 (set "*App") 71 (let gui 72 '((X . @) 73 (inc '"*Ix") 74 (with 75 (cond 76 ((pair X) (pass new X)) 77 ((not X) (pass new)) 78 ((num? X) 79 (ifn "*Chart" 80 (quit "no chart" (rest)) 81 (with "*Chart" 82 (let L (last (: gui)) 83 (when (get L X) 84 (inc (:: rows)) 85 (queue (:: gui) (setq L (need (: cols)))) ) 86 (let Fld (pass new) 87 (set (nth L X) Fld) 88 (put Fld 'chart (list This (: rows) X)) 89 (and (get Fld 'chg) (get Fld 'able) (=: lock)) 90 (set> Fld 91 (get 92 ((: put) 93 (get (nth (: data) (: ofs)) (: rows)) 94 (+ (: ofs) (: rows) -1) ) 95 X ) 96 T ) 97 Fld ) ) ) ) ) 98 ((get "*App" X) (quit "gui conflict" X)) 99 (T (put "*App" X (pass new))) ) 100 (queue (:: home gui) This) 101 (unless (: chart) (init> This)) 102 (when (: id) 103 (let *Gui (val "*App") 104 (show> This (cons '*Gui (: id))) ) ) 105 This ) ) 106 (htPrin "Prg") ) ) ) 107 (--) 108 (eval (: show)) ) ) ) 109 110 # Disable form 111 (de disable (Flg) 112 (and Flg (=: able)) ) 113 114 # Handle form actions 115 (de action "Prg" 116 (off "*Foc") 117 (or *PRG "*Post2" (off "*Err")) 118 (catch "stop" 119 (nond 120 (*Post 121 (unless (and *PRG (= *Form (car *Got)) (= *Get (cadr *Got))) 122 (pushForm (cons)) ) 123 (if *Port% 124 (let *JS NIL (_doForm)) 125 (_doForm) ) 126 (off *PRG *Got) ) 127 (*PRG 128 (with (postForm) 129 (ifn (= *Evt (: evt)) 130 (noContent) 131 (postGui) 132 (redirect 133 (baseHRef) 134 *SesId 135 (urlMT *Url *Menu *Tab *ID) 136 "&*Evt=+" (inc (:: evt)) 137 "&*Got=_+" *Form "_+" *Get ) ) ) ) 138 (NIL 139 (off *PRG) 140 (pushForm (cons)) 141 (_doForm) ) ) ) ) 142 143 (de pushForm (L) 144 (push '"*Lst" L) 145 (and (nth "*Lst" 99) (con @)) 146 (setq *Get "*Cnt") 147 (inc '"*Cnt") ) 148 149 (de _doForm () 150 (one *Form) 151 (run "Prg") 152 (setq "*Stat" 153 (cons 154 (pair "*Err") 155 (copy (get "*Lst" (- "*Cnt" *Get))) ) ) ) 156 157 (de jsForm (Url) 158 (if (or *PRG (not *Post)) 159 (noContent) 160 (setq *Url Url Url (chop Url)) 161 (let action 162 '(Prg 163 (off "*Err") 164 (with (postForm) 165 (catch "stop" 166 (postGui) 167 (httpHead "text/plain; charset=utf-8") 168 (if 169 (and 170 (= (car "*Stat") "*Err") 171 (= (cdr "*Stat") (get "*Lst" (- "*Cnt" *Get))) ) 172 (ht:Out *Chunked 173 (when (: auto) 174 (prin "i" *Form '- (: auto 1 id) ': (: auto -1)) 175 (=: auto) ) 176 (for S *Spans 177 (prin '& (car S) '& (run (cdr S))) ) 178 (for This (: gui) 179 (if (: id) 180 (prin '& "i" *Form '- @ '& (js> This)) 181 (setq "*Chart" This) ) ) ) 182 (setq "*Post2" (cons *Get *Form *PRG)) 183 (ht:Out *Chunked (prin T)) ) ) ) 184 (off *PRG) ) 185 (use @X 186 (cond 187 ((match '("-" @X "." "h" "t" "m" "l") Url) 188 (try 'html> (extern (ht:Pack @X))) ) 189 ((disallowed) 190 (notAllowed *Url) 191 (http404) ) 192 ((= '! (car Url)) 193 ((intern (pack (cdr Url)))) ) 194 ((tail '("." "l") Url) 195 (load *Url) ) ) ) ) ) ) 196 197 (de postForm () 198 (let? Lst (get "*Lst" (- "*Cnt" (setq *Get (format *Get)))) 199 (setq 200 *Form (format *Form) 201 *Evt (format *Evt) 202 *PRG 203 (cond 204 ((and (= *Get (car "*Post2")) (= *Form (cadr "*Post2"))) 205 (cddr "*Post2") ) 206 ((off "*Post2")) 207 ((gt0 *Form) (get Lst *Form)) 208 (T (get Lst 1 (+ (length (car Lst)) *Form) 1)) ) ) ) ) 209 210 (de postGui () 211 (if "*Post2" 212 (off *Gui "*Post2") 213 (let ("Fun" NIL *Btn NIL) 214 (for G *Gui 215 (if (=0 (car G)) 216 (setq "Fun" (cdr G)) 217 (and (lt0 (car G)) (setq *Btn (cdr G))) 218 (con (assoc (car G) (val *PRG)) (cdr G)) ) ) 219 (off *Gui) 220 (job (: env) 221 (for This (: gui) 222 (cond 223 ((not (: id)) (setq "*Chart" This)) 224 ((chk> This) (error @)) 225 ((or (: rid) (: home able)) 226 (set> This (val> This) T) ) ) ) 227 (for This (: gui) 228 (cond 229 ((: id)) 230 ((chk> (setq "*Chart" This)) (error @)) 231 ((or (: rid) (: home able)) 232 (set> This (val> This)) ) ) ) 233 (if (pair "*Err") 234 (and *Lock (with (caar "*Err") (tryLock *Lock))) 235 (finally 236 (when *Lock 237 (if (lock @) 238 (=: able (off *Lock)) 239 (sync) 240 (tell) ) ) 241 (when "Fun" 242 (when (and *Allow (not (idx *Allow "Fun"))) 243 (notAllowed "Fun") 244 (throw "stop") ) 245 (apply (intern "Fun") 246 (mapcar 247 '((X) 248 ((if (= "+" (car (setq X (chop (cdr X))))) format pack) 249 (cdr X) ) ) 250 *JsArgs ) ) ) 251 (for This (: gui) 252 (nond 253 ((: id) (setq "*Chart" This)) 254 ((ge0 (: id)) 255 (let? A (assoc (: id) (val *PRG)) 256 (when (cdr A) 257 (con A) 258 (act> This) ) ) ) ) ) ) 259 (for This (: gui) 260 (or (: id) (setq "*Chart" This)) 261 (upd> This) ) ) ) ) ) ) 262 263 (de error (Exe) 264 (cond 265 ((=T Exe) (on "*Err")) 266 ((nT "*Err") (queue '"*Err" (cons This Exe))) ) ) 267 268 (de url (Url . @) 269 (when Url 270 (off *PRG) 271 (redirect (baseHRef) *SesId Url '? 272 (pack 273 (make 274 (loop 275 (and 276 (sym? (next)) 277 (= `(char '*) (char (arg))) 278 (link (arg) '=) 279 (next) ) 280 (link (ht:Fmt (arg))) 281 (NIL (args)) 282 (link '&) ) ) ) ) 283 (throw "stop") ) ) 284 285 # Actve <span> elements 286 (de span Args 287 (def (car Args) 288 (list NIL 289 (list '<span> 290 (lit (cons 'id (car Args))) 291 (cons 'ht:Prin (cdr Args)) ) ) ) 292 (push '*Spans Args) ) 293 294 (span expires 295 (pack 296 "TimeOut" 297 " " 298 (let Tim (+ (time T) (/ (cadr (assoc -1 *Run)) 1000)) 299 (if "*TZO" 300 (tim$ (% (- Tim -86400 @) 86400)) 301 (javascript NIL 302 "lisp(null, 'tzOffs', (new Date()).getTimezoneOffset());" ) 303 (pack (tim$ (% Tim 86400)) " UTC") ) ) ) ) 304 305 # Return chart property 306 (de chart @ 307 (pass get "*Chart") ) 308 309 # Table highlighting 310 (daemon '<table> 311 (on "rowF") ) 312 313 (de alternating () 314 (onOff "rowF") ) 315 316 # REPL form 317 (de repl (Attr) 318 (form Attr 319 (gui 'view '(+FileField) '(tmp "repl") 80 25) 320 (--) 321 (gui 'line '(+Focus +TextField) 64 ":") 322 (gui '(+JS +Button) "eval" 323 '(let Str (val> (: home line)) 324 (out (pack "+" (tmp "repl")) 325 (prinl ": " Str) 326 (catch '(NIL) 327 (let Res (in "/dev/null" (eval (any Str))) 328 (prin "-> ") 329 (println Res) ) ) 330 (when *Msg (prinl @) (off *Msg)) ) 331 (clr> (: home line)) ) ) 332 (gui '(+JS +Button) "clear" 333 '(clr> (: home view)) ) ) ) 334 335 336 # Dialogs 337 (de _dlg (Attr Env) 338 (let L (get "*Lst" (- "*Cnt" *Get)) 339 (while (and (car L) (n== *PRG (caar @))) 340 (pop L) ) 341 (push L 342 (list 343 (new NIL NIL 'btn This 'able T 'evt 0 'env Env) 344 Attr 345 Prg ) ) 346 (pushForm L) ) ) 347 348 (de dialog (Env . Prg) 349 (_dlg 'dialog Env) ) 350 351 (de alert (Env . Prg) 352 (_dlg 'alert Env) ) 353 354 (de note (Str Lst) 355 (alert (env '(Str Lst)) 356 (<span> 'note Str) 357 (--) 358 (for S Lst (<br> S)) 359 (okButton) ) ) 360 361 (de ask (Str . Prg) 362 (alert (env '(Str Prg)) 363 (<span> 'ask Str) 364 (--) 365 (yesButton (cons 'prog Prg)) 366 (noButton) ) ) 367 368 (de diaform (Lst . Prg) 369 (cond 370 ((num? (caar Lst)) # Dst 371 (gui (gt0 (caar Lst)) '(+ChoButton) 372 (cons 'diaform 373 (list 'cons 374 (list 'cons (lit (car Lst)) '(field 1)) 375 (lit (env (cdr Lst))) ) 376 Prg ) ) ) 377 ((and *PRG (not (: diaform))) 378 (_dlg 'dialog (env Lst)) ) 379 (T 380 (=: env (env Lst)) 381 (=: diaform T) 382 (run Prg 1) ) ) ) 383 384 (de saveButton (Exe) 385 (gui '(+Button) ,"Save" Exe) ) 386 387 (de closeButton (Lbl Exe) 388 (when (get "*App" 'top) 389 (gui '(+Rid +Close +Button) Lbl Exe) ) ) 390 391 (de okButton (Exe) 392 (when (get "*App" 'top) 393 (if (=T Exe) 394 (gui '(+Force +Close +Button) T "OK") 395 (gui '(+Close +Button) "OK" Exe) ) ) ) 396 397 (de cancelButton () 398 (when (get "*App" 'top) 399 (gui '(+Force +Close +Button) T ',"Cancel") ) ) 400 401 (de yesButton (Exe) 402 (gui '(+Close +Button) ',"Yes" Exe) ) 403 404 (de noButton (Exe) 405 (gui '(+Close +Button) ',"No" Exe) ) 406 407 (de choButton (Exe) 408 (gui '(+Rid +Tip +Button) 409 ,"Find or create an object of the same type" 410 ',"Select" Exe ) ) 411 412 413 (class +Force) 414 # force 415 416 (dm T (Exe . @) 417 (=: force Exe) 418 (pass extra) ) 419 420 (dm chk> () 421 (when 422 (and 423 (cdr (assoc (: id) (val *PRG))) 424 (eval (: force)) ) 425 (for A (val *PRG) 426 (and 427 (lt0 (car A)) 428 (<> (: id) (car A)) 429 (con A) ) ) 430 T ) ) 431 432 433 (class +Close) 434 435 (dm act> () 436 (when (able) 437 (and 438 (get "*Lst" (- "*Cnt" *Get)) 439 (pushForm 440 (cons 441 (filter 442 '((L) (memq (car L) (: home top))) 443 (car @) ) 444 (cdr @) ) ) ) 445 (extra) 446 (for This (: home top) 447 (for This (: gui) 448 (or (: id) (setq "*Chart" This)) 449 (upd> This) ) ) ) ) 450 451 452 # Choose a value 453 (class +ChoButton +Tiny +Tip +Button) 454 455 (dm T (Exe) 456 (super ,"Choose a suitable value" "+" Exe) 457 (=: chg T) ) 458 459 460 (class +PickButton +Tiny +Tip +Button) 461 462 (dm T (Exe) 463 (super ,"Adopt this value" "@" Exe) ) 464 465 466 (class +DstButton +Set +Able +Close +PickButton) 467 # msg obj 468 469 (dm T (Dst Msg) 470 (=: msg (or Msg 'url>)) 471 (super 472 '((Obj) (=: obj Obj)) 473 '(: obj) 474 (when Dst 475 (or 476 (pair Dst) 477 (list 'chgDst (lit Dst) '(: obj)) ) ) ) ) 478 479 (de chgDst (This Val) 480 (set> This (if (: new) (@ Val) Val)) ) 481 482 (dm js> () 483 (cond 484 ((: act) (super)) 485 ((try (: msg) (: obj) 1) 486 (pack "@&+" (ht:Fmt (sesId (mkUrl @)))) ) 487 (T "@") ) ) 488 489 (dm show> ("Var") 490 (if (: act) 491 (super "Var") 492 (<style> (cons 'id (pack "i" *Form '- (: id))) 493 (if (try (: msg) (: obj) 1) 494 (<tip> "-->" (<href> "@" (mkUrl @))) 495 (<span> *Style "@") ) ) ) ) 496 497 498 (class +Choice +ChoButton) 499 # ttl hint 500 501 (dm T (Ttl Exe) 502 (=: ttl Ttl) 503 (=: hint Exe) 504 (super 505 '(dialog (env 'Ttl (eval (: ttl)) 'Lst (eval (: hint)) 'Dst (field 1)) 506 (<table> 'chart Ttl '((btn) NIL) 507 (for X Lst 508 (<row> NIL 509 (gui '(+Close +PickButton) 510 (list 'set> 'Dst 511 (if (get Dst 'dy) 512 (list 'pack '(str> Dst) (fin X)) 513 (lit (fin X)) ) ) ) 514 (ht:Prin (if (atom X) X (car X))) ) ) ) 515 (cancelButton) ) ) ) 516 517 518 (class +Tok) 519 520 (dm T @ 521 (=: tok T) 522 (pass extra) ) 523 524 525 (class +Coy) 526 527 (dm T @ 528 (=: coy T) 529 (pass extra) ) 530 531 532 (class +hint) 533 # tok coy 534 535 (dm show> ("Var") 536 (<js> 537 (list 538 '("autocomplete" . "off") 539 '("onfocus" . "doHint(this)") 540 (cons 541 "onkeyup" 542 (pack 543 "return hintKey(this,event" 544 (if2 (: tok) (: coy) ",true,true" ",true" ",false,true") 545 ")" ) ) ) 546 (extra "Var") ) ) 547 548 (de jsHint (I) 549 (httpHead "text/plain; charset=utf-8") 550 (ht:Out *Chunked 551 (let? L 552 (if (sym? I) 553 ((; I hint) *JsHint) 554 (let? Lst (get "*Lst" (- "*Cnt" (format *Get))) 555 (pair 556 (hint> 557 (get 558 (if (gt0 (format *Form)) 559 (get Lst @) 560 (get Lst 1 (+ (length (car Lst)) (format *Form)) 1) ) 561 'gui 562 I ) 563 *JsHint ) ) ) ) 564 (prin 565 (ht:Fmt 566 (if (atom (car L)) 567 (car L) 568 (caar L) ) ) ) 569 (for X (cdr L) 570 (prin '& 571 (ht:Fmt (if (atom X) X (car X))) ) ) ) ) ) 572 573 574 (class +Hint +hint) 575 # hint 576 577 (dm T (Fun . @) 578 (=: hint Fun) 579 (pass extra) ) 580 581 (dm hint> (Str) 582 ((: hint) (extra Str)) ) 583 584 (de queryHint (Var CL) 585 (make 586 (for (Q (goal CL) (prove Q)) 587 (let V (get (asoq '@@ @) -1 Var) 588 (unless (member V (made)) 589 (link V) ) ) 590 (T (nth (made) 24)) ) ) ) 591 592 (de dbHint (Str Var Cls Hook) 593 (queryHint Var 594 (cons (list 'db Var Cls Hook Str '@@)) ) ) 595 596 597 (class +DbHint +Hint) 598 599 (dm T (Rel . @) 600 (pass super 601 (list '(Str) 602 (list 'dbHint 'Str 603 (lit (car Rel)) 604 (lit (last Rel)) 605 (and (meta (cdr Rel) (car Rel) 'hook) (next)) ) ) ) ) 606 607 608 (class +Hint1 +hint) 609 # hint 610 611 (dm T (Exe . @) 612 (=: hint Exe) 613 (pass extra) ) 614 615 (dm hint> (Str) 616 (setq Str (extra Str)) 617 (extract '((S) (pre? Str S)) 618 (eval (: hint)) ) ) 619 620 621 (class +Hint2 +hint) 622 623 (dm hint> (Str) 624 (setq Str (extra Str)) 625 (extract '((X) (pre? Str (if (atom X) X (car X)))) 626 (with (field -1) (eval (: hint))) ) ) 627 628 629 (class +Txt) 630 # txt 631 632 (dm T (Fun . @) 633 (=: txt Fun) 634 (pass extra) ) 635 636 (dm txt> (Val) 637 ((: txt) Val) ) 638 639 640 (class +Set) 641 # set 642 643 (dm T (Fun . @) 644 (=: set Fun) 645 (pass extra) ) 646 647 (dm set> (Val Dn) 648 (extra ((: set) Val) Dn) ) 649 650 651 (class +Val) 652 # val 653 654 (dm T (Fun . @) 655 (=: val Fun) 656 (pass extra) ) 657 658 (dm val> () 659 ((: val) (extra)) ) 660 661 662 (class +Fmt) 663 # set val 664 665 (dm T (Fun1 Fun2 . @) 666 (=: set Fun1) 667 (=: val Fun2) 668 (pass extra) ) 669 670 (dm set> (Val Dn) 671 (extra ((: set) Val) Dn) ) 672 673 (dm val> () 674 ((: val) (extra)) ) 675 676 677 (class +Chg) 678 # old new 679 680 (dm T (Fun . @) 681 (=: new Fun) 682 (pass extra) ) 683 684 (dm set> (Val Dn) 685 (extra (=: old Val) Dn) ) 686 687 (dm val> () 688 (let Val (extra) 689 (if (= (: old) Val) 690 Val 691 ((: new) Val) ) ) ) 692 693 694 (class +Upd) 695 # upd 696 697 (dm T (Exe . @) 698 (=: upd Exe) 699 (pass extra) ) 700 701 (dm upd> () 702 (set> This (eval (: upd))) ) 703 704 705 (class +Init) 706 # init 707 708 (dm T (Val . @) 709 (=: init Val) 710 (pass extra) ) 711 712 (dm init> () 713 (set> This (: init)) ) 714 715 716 (class +Dflt) 717 # dflt 718 719 (dm T (Exe . @) 720 (=: dflt Exe) 721 (pass extra) ) 722 723 (dm set> (Val Dn) 724 (extra (or Val (eval (: dflt))) Dn) ) 725 726 (dm val> () 727 (let Val (extra) 728 (unless (= Val (eval (: dflt))) Val) ) ) 729 730 731 (class +Cue) 732 # cue 733 734 (dm T (Str . @) 735 (=: cue (pack "<" Str ">")) 736 (pass extra) ) 737 738 (dm show> ("Var") 739 (<js> 740 (cons (cons "placeholder" (: cue))) 741 (extra "Var") ) ) 742 743 744 (class +Trim) 745 746 (dm val> () 747 (pack (trim (chop (extra)))) ) 748 749 750 (class +Enum) 751 # enum 752 753 (dm T (Lst . @) 754 (=: enum Lst) 755 (pass extra) ) 756 757 (dm set> (N Dn) 758 (extra (get (: enum) N) Dn) ) 759 760 (dm val> () 761 (index (extra) (: enum)) ) 762 763 764 (class +Map) 765 # map 766 767 (dm T (Lst . @) 768 (=: map Lst) 769 (pass extra) ) 770 771 (dm set> (Val Dn) 772 (extra 773 (if 774 (find 775 '((X) (= Val (cdr X))) 776 (: map) ) 777 (val (car @)) 778 Val ) 779 Dn ) ) 780 781 (dm val> () 782 (let Val (extra) 783 (if 784 (find 785 '((X) (= Val (val (car X)))) 786 (: map) ) 787 (cdr @) 788 Val ) ) ) 789 790 791 # Case conversions 792 (class +Uppc) 793 794 (dm set> (Val Dn) 795 (extra (uppc Val) Dn) ) 796 797 (dm val> () 798 (uppc (extra)) ) 799 800 (dm hint> (Str) 801 (extra (uppc Str)) ) 802 803 804 (class +Lowc) 805 806 (dm set> (Val Dn) 807 (extra (lowc Val) Dn) ) 808 809 (dm val> () 810 (lowc (extra)) ) 811 812 (dm hint> (Str) 813 (extra (lowc Str)) ) 814 815 816 # Field enable/disable 817 (de able () 818 (when (or (: rid) (: home able)) 819 (eval (: able)) ) ) 820 821 (class +Able) 822 823 (dm T (Exe . @) 824 (pass extra) 825 (when (: able) 826 (=: able 827 (cond 828 ((=T (: able)) Exe) 829 ((and (pair (: able)) (== 'and (car @))) 830 (cons 'and Exe (cdr (: able))) ) 831 (T (list 'and Exe (: able))) ) ) ) ) 832 833 834 (class +Lock +Able) 835 836 (dm T @ 837 (pass super NIL) ) 838 839 840 (class +View +Lock +Upd) 841 842 843 # Escape from form lock 844 (class +Rid) 845 # rid 846 847 (dm T @ 848 (=: rid T) 849 (pass extra) ) 850 851 852 (class +Align) 853 854 (dm T @ 855 (=: align T) 856 (pass extra) ) 857 858 859 (class +Limit) 860 # lim 861 862 (dm T (Exe . @) 863 (=: lim Exe) 864 (pass extra) ) 865 866 867 (class +Clr0) 868 869 (dm val> () 870 (let N (extra) 871 (unless (=0 N) N) ) ) 872 873 874 (class +Var) 875 # var 876 877 (dm T (Var . @) 878 (=: var Var) 879 (pass extra) ) 880 881 (dm set> (Val Dn) 882 (extra (set (: var) Val) Dn) ) 883 884 (dm upd> () 885 (set> This (val (: var))) ) 886 887 888 (class +Chk) 889 # chk 890 891 (dm T (Exe . @) 892 (=: chk Exe) 893 (pass extra) ) 894 895 (dm chk> () 896 (eval (: chk)) ) 897 898 899 (class +Tip) 900 # tip 901 902 (dm T (Exe . @) 903 (=: tip Exe) 904 (pass extra) ) 905 906 (dm show> ("Var") 907 (<tip> (eval (: tip)) (extra "Var")) ) 908 909 (dm js> () 910 (pack (extra) "&?" (ht:Fmt (eval (: tip)))) ) 911 912 913 (class +Tiny) 914 915 (dm show> ("Var") 916 (<style> 'tiny (extra "Var")) ) 917 918 919 (class +Click) 920 # clk 921 922 (dm T (Exe . @) 923 (=: clk Exe) 924 (pass extra) ) 925 926 (dm show> ("Var") 927 (extra "Var") 928 (and 929 (atom "*Err") 930 (eval (: clk)) 931 (javascript NIL 932 "window.setTimeout(\"document.getElementById(\\\"" 933 "i" *Form '- (: id) 934 "\\\").click()\"," 935 @ 936 ")" ) ) ) 937 938 939 (class +Focus) 940 941 (dm show> ("Var") 942 (extra "Var") 943 (when (and (able) (not "*Foc")) 944 (on "*Foc") 945 (javascript NIL 946 "window.setTimeout(\"document.getElementById(\\\"" 947 "i" *Form '- (: id) 948 "\\\").focus()\",420)" ) ) ) 949 950 ### Styles ### 951 (class +Style) 952 # style 953 954 (dm T (Exe . @) 955 (=: style Exe) 956 (pass extra) ) 957 958 (dm show> ("Var") 959 (<style> (eval (: style)) (extra "Var")) ) 960 961 (dm js> () 962 (pack (extra) "&#" (eval (: style))) ) 963 964 965 # Monospace font 966 (class +Mono) 967 968 (dm show> ("Var") 969 (<style> "mono" (extra "Var")) ) 970 971 (dm js> () 972 (pack (extra) "&#mono") ) 973 974 975 # Signum field 976 (class +Sgn) 977 978 (dm show> ("Var") 979 (<style> (and (lt0 (val> This)) "red") (extra "Var")) ) 980 981 (dm js> () 982 (pack (extra) "&#" (and (lt0 (val> This)) "red")) ) 983 984 ### Form field classes ### 985 (de showFld "Prg" 986 (when (: lbl) 987 (ht:Prin (eval @)) 988 (<nbsp>) ) 989 (style (cons 'id (pack "i" *Form '- (: id))) "Prg") ) 990 991 992 (class +gui) 993 # home id chg able chart 994 995 (dm T () 996 (push (=: home "*App") (cons (=: id "*Ix"))) 997 (=: able T) ) 998 999 (dm txt> (Val)) 1000 1001 (dm set> (Val Dn)) 1002 1003 (dm clr> () 1004 (set> This) ) 1005 1006 (dm val> ()) 1007 1008 (dm hint> (Str) 1009 Str ) 1010 1011 (dm init> () 1012 (upd> This) ) 1013 1014 (dm upd> ()) 1015 1016 (dm chk> ()) 1017 1018 1019 (class +field +gui) 1020 1021 (dm T () 1022 (super) 1023 (=: chg T) ) 1024 1025 (dm txt> (Val) 1026 Val ) 1027 1028 (dm js> () 1029 (let S (ht:Fmt (cdr (assoc (: id) (val *PRG)))) 1030 (if (able) S (pack S "&=")) ) ) 1031 1032 (dm set> (Str Dn) 1033 (con (assoc (: id) (val (: home))) Str) 1034 (and (not Dn) (: chart) (set> (car @) (val> (car @)))) ) 1035 1036 (dm str> () 1037 (cdr (assoc (: id) (val (: home)))) ) 1038 1039 (dm val> () 1040 (str> This) ) 1041 1042 1043 # Get field 1044 (de field (X . @) 1045 (if (sym? X) 1046 (pass get (: home) X) 1047 (pass get (: home gui) (+ X (abs (: id)))) ) ) 1048 1049 # Get current chart data row 1050 (de row (D) 1051 (+ (: chart 1 ofs) (: chart 2) -1 (or D 0)) ) 1052 1053 (de curr @ 1054 (pass get (: chart 1 data) (row)) ) 1055 1056 (de prev @ 1057 (pass get (: chart 1 data) (row -1)) ) 1058 1059 1060 (class +Button +gui) 1061 # img lbl alt act js 1062 1063 # ([T] lbl [alt] act) 1064 (dm T @ 1065 (and (=: img (=T (next))) (next)) 1066 (=: lbl (arg)) 1067 (let X (next) 1068 (ifn (args) 1069 (=: act X) 1070 (=: alt X) 1071 (=: act (next)) ) ) 1072 (super) 1073 (set 1074 (car (val "*App")) 1075 (=: id (- (: id))) ) ) 1076 1077 (dm js> () 1078 (if (able) 1079 (let Str (ht:Fmt (eval (: lbl))) 1080 (if (: img) (sesId Str) Str) ) 1081 (let Str (ht:Fmt (or (eval (: alt)) (eval (: lbl)))) 1082 (pack (if (: img) (sesId Str) Str) "&=") ) ) ) 1083 1084 (dm show> ("Var") 1085 (<style> (cons 'id (pack "i" *Form '- (: id))) 1086 (if (able) 1087 (let Str (eval (: lbl)) 1088 ((if (: img) <image> <submit>) Str "Var" NIL (: js)) ) 1089 (let Str (or (eval (: alt)) (eval (: lbl))) 1090 ((if (: img) <image> <submit>) Str "Var" T (: js)) ) ) ) ) 1091 1092 (dm act> () 1093 (and (able) (eval (: act))) ) 1094 1095 1096 (class +OnClick) 1097 # onclick 1098 1099 (dm T (Exe . @) 1100 (=: onclick Exe) 1101 (pass extra) ) 1102 1103 (dm show> ("Var") 1104 (<js> (list (cons 'onclick (eval (: onclick)))) 1105 (extra "Var") ) ) 1106 1107 1108 (class +Drop) 1109 # "drop" drop 1110 1111 (dm T (Fld . @) 1112 (=: "drop" Fld) 1113 (pass extra) ) 1114 1115 (dm show> ("Var") 1116 (<js> 1117 (quote 1118 ("ondragenter" . "doDrag(event)") 1119 ("ondragover" . "doDrag(event)") 1120 ("ondrop" . "doDrop(this,event)") ) 1121 (extra "Var") ) ) 1122 1123 (dm act> () 1124 (=: drop 1125 (and 1126 (or *Drop (val> (eval (: "drop")))) 1127 (tmp @) ) ) 1128 (extra) 1129 (off *Drop) ) 1130 1131 1132 (class +JS) 1133 1134 (dm T @ 1135 (=: js T) 1136 (pass extra) ) 1137 1138 1139 (class +Auto +JS) 1140 # auto 1141 1142 (dm T (Fld Exe . @) 1143 (=: auto (cons Fld Exe)) 1144 (pass super) ) 1145 1146 (dm act> () 1147 (when (able) 1148 (=: home auto 1149 (cons 1150 (eval (car (: auto))) 1151 (eval (cdr (: auto))) ) ) 1152 (extra) ) ) 1153 1154 1155 (class +DnButton +Tiny +Rid +JS +Able +Button) 1156 1157 (dm T (Exe Lbl) 1158 (super 1159 '(> (length (chart 'data)) (chart 'ofs)) 1160 (or Lbl ">") 1161 (list 'scroll> (lit "*Chart") Exe) ) ) 1162 1163 1164 (class +UpButton +Tiny +Rid +JS +Able +Button) 1165 1166 (dm T (Exe Lbl) 1167 (super 1168 '(> (chart 'ofs) 1) 1169 (or Lbl "<") 1170 (list 'scroll> (lit "*Chart") (list '- Exe)) ) ) 1171 1172 (class +GoButton +Tiny +Rid +JS +Able +Button) 1173 1174 (dm T (Exe Lbl) 1175 (super 1176 (list 'and 1177 (list '>= '(length (chart 'data)) Exe) 1178 (list '<> '(chart 'ofs) Exe) ) 1179 Lbl 1180 (list 'goto> (lit "*Chart") Exe) ) ) 1181 1182 (de scroll (N Flg) 1183 (when Flg 1184 (gui '(+Tip +GoButton) ,"Go to first line" 1 "|<") ) 1185 (gui '(+Tip +UpButton) ,"Scroll up one page" N "<<") 1186 (gui '(+Tip +UpButton) ,"Scroll up one line" 1) 1187 (gui '(+Tip +DnButton) ,"Scroll down one line" 1) 1188 (gui '(+Tip +DnButton) ,"Scroll down one page" N ">>") 1189 (when Flg 1190 (gui '(+Tip +GoButton) ,"Go to last line" 1191 (list '- '(length (chart 'data)) (dec N)) 1192 ">|" ) 1193 (<nbsp>) 1194 (gui '(+View +TextField) 1195 '(let? Len (gt0 (length (chart 'data))) 1196 (pack 1197 (chart 'ofs) 1198 "-" 1199 (min Len (dec (+ (chart 'ofs) (chart 'rows)))) 1200 " / " 1201 Len ) ) ) ) ) 1202 1203 1204 # Delete row 1205 (class +DelRowButton +Tiny +JS +Able +Tip +Button) 1206 # del exe 1207 1208 (dm T (Txt Exe) 1209 (=: del Txt) 1210 (=: exe Exe) 1211 (super '(nth (: chart 1 data) (row)) ,"Delete row" "x" 1212 '(if (or (: home del) (not (curr))) 1213 (_delRow (: exe)) 1214 (ask (if (: del) (eval @) ,"Delete row?") 1215 (with (: home btn) 1216 (=: home del T) 1217 (_delRow (: exe)) ) ) ) ) ) 1218 1219 (de _delRow (Exe) 1220 (eval Exe) 1221 (set> (: chart 1) 1222 (remove (row) (val> (: chart 1))) ) ) 1223 1224 # Move row up 1225 (class +BubbleButton +Tiny +JS +Able +Tip +Button) 1226 1227 (dm T () 1228 (super 1229 '(> (: chart 2) 1) 1230 ,"Shift row up" 1231 "\^" 1232 '(let L (val> (: chart 1)) 1233 (set> (: chart 1) 1234 (conc 1235 (cut (row -2) 'L) 1236 (cons (cadr L)) 1237 (cons (car L)) 1238 (cddr L) ) ) ) ) ) 1239 1240 1241 (class +ClrButton +JS +Tip +Button) 1242 # clr 1243 1244 (dm T (Lbl Lst . @) 1245 (=: clr Lst) 1246 (pass super ,"Clear all input fields" Lbl 1247 '(for X (: clr) 1248 (if (atom X) 1249 (clr> (field X)) 1250 (set> (field (car X)) (eval (cdr X))) ) ) ) ) 1251 1252 1253 (class +ShowButton +Button) 1254 1255 (dm T (Flg Exe) 1256 (super ,"Show" 1257 (list '=: 'home 'show (lit Exe)) ) 1258 (and Flg (=: home show Exe)) ) 1259 1260 1261 (class +Checkbox +field) 1262 # lbl 1263 1264 # ([lbl]) 1265 (dm T (Lbl) 1266 (=: lbl Lbl) 1267 (super) ) 1268 1269 (dm txt> (Val) 1270 (if Val ,"Yes" ,"No") ) 1271 1272 (dm show> ("Var") 1273 (showFld (<check> "Var" (not (able)))) ) 1274 1275 (dm set> (Val Dn) 1276 (super (bool Val) Dn) ) 1277 1278 (dm val> () 1279 (bool (super)) ) 1280 1281 1282 (class +Radio +field) # Inited by Tomas Hlavaty <kvietaag@seznam.cz> 1283 # grp val lbl 1284 1285 # (grp val [lbl]) 1286 (dm T (Grp Val Lbl) 1287 (super) 1288 (=: grp (if Grp (field @) This)) 1289 (=: val Val) 1290 (=: lbl Lbl) ) 1291 1292 (dm show> ("Var") 1293 (showFld 1294 (<radio> 1295 (cons '*Gui (: grp id)) 1296 (: val) 1297 (not (able)) ) ) ) 1298 1299 (dm js> () 1300 (pack 1301 (ht:Fmt (: val)) 1302 "&" (= (: val) (str> (: grp))) 1303 (unless (able) "&=") ) ) 1304 1305 (dm set> (Val Dn) 1306 (when (== This (: grp)) 1307 (super Val Dn) ) ) 1308 1309 1310 (class +TextField +field) 1311 # dx dy lst lbl lim align 1312 1313 # ([dx [dy] [lbl]]) 1314 # ([lst [lbl]]) 1315 (dm T (X . @) 1316 (nond 1317 ((num? X) 1318 (=: lst X) 1319 (=: lbl (next)) ) 1320 ((num? (next)) 1321 (=: dx X) 1322 (=: lbl (arg)) ) 1323 (NIL 1324 (=: dx X) 1325 (=: dy (arg)) 1326 (=: lbl (next)) ) ) 1327 (super) 1328 (or (: dx) (: lst) (=: chg)) ) 1329 1330 (dm show> ("Var") 1331 (showFld 1332 (cond 1333 ((: dy) 1334 (<area> (: dx) (: dy) "Var" (not (able))) ) 1335 ((: dx) 1336 (<field> 1337 (if (: align) (- (: dx)) (: dx)) 1338 "Var" 1339 (eval (: lim)) 1340 (not (able)) ) ) 1341 ((: lst) 1342 (let 1343 (L 1344 (mapcar 1345 '(("X") 1346 (if (atom "X") 1347 (val "X") 1348 (cons (val (car "X")) (val (cdr "X"))) ) ) 1349 @ ) 1350 S (str> This) ) 1351 (<select> 1352 (if (or (member S L) (assoc S L)) 1353 L 1354 (cons S L) ) 1355 "Var" 1356 (not (able)) ) ) ) 1357 (T 1358 (<style> (cons 'id (pack "i" *Form '- (: id))) 1359 (<span> *Style 1360 (if (str> This) (ht:Prin @) (<nbsp>)) ) ) ) ) ) ) 1361 1362 1363 (class +LinesField +TextField) 1364 1365 (dm set> (Val Dn) 1366 (super (glue "^J" Val) Dn) ) 1367 1368 (dm val> () 1369 (split (chop (super)) "^J") ) 1370 1371 1372 (class +ListTextField +TextField) 1373 # split 1374 1375 (dm T (Lst . @) 1376 (=: split Lst) 1377 (pass super) ) 1378 1379 (dm set> (Val Dn) 1380 (super (glue (car (: split)) Val) Dn) ) 1381 1382 (dm val> () 1383 (extract pack 1384 (apply split (: split) (chop (super))) ) ) 1385 1386 1387 # Password field 1388 (class +PwField +TextField) 1389 1390 (dm show> ("Var") 1391 (showFld 1392 (<passwd> (: dx) "Var" (eval (: lim)) (not (able))) ) ) 1393 1394 1395 # Upload field 1396 (class +UpField +TextField) 1397 1398 (dm show> ("Var") 1399 (showFld 1400 (<upload> (: dx) "Var" (not (able))) ) ) 1401 1402 1403 # Symbol fields 1404 (class +SymField +TextField) 1405 1406 (dm val> () 1407 (let S (super) 1408 (and (<> "-" S) (intern S)) ) ) 1409 1410 (dm set> (Val Dn) 1411 (super (name Val) Dn) ) 1412 1413 1414 (class +numField +Align +TextField) 1415 # scl 1416 1417 (dm chk> () 1418 (and 1419 (str> This) 1420 (not (format @ (: scl) *Sep0 *Sep3)) 1421 ,"Numeric input expected" ) ) 1422 1423 1424 (class +NumField +numField) 1425 1426 (dm txt> (Val) 1427 (format Val) ) 1428 1429 (dm set> (Val Dn) 1430 (super (format Val) Dn) ) 1431 1432 (dm val> () 1433 (format (super) NIL *Sep0 *Sep3) ) 1434 1435 1436 (class +FixField +numField) 1437 1438 (dm T (N . @) 1439 (=: scl N) 1440 (pass super) ) 1441 1442 (dm txt> (Val) 1443 (format Val (: scl) *Sep0 *Sep3) ) 1444 1445 (dm set> (Val Dn) 1446 (super (format Val (: scl) *Sep0 *Sep3) Dn) ) 1447 1448 (dm val> () 1449 (let S (super) 1450 (format 1451 (if (sub? *Sep0 S) S (pack S *Sep0)) 1452 (: scl) 1453 *Sep0 1454 *Sep3 ) ) ) 1455 1456 1457 (class +AtomField +Mono +TextField) 1458 1459 (dm set> (Val Dn) 1460 (super 1461 (if (num? Val) 1462 (align (: dx) (format Val)) 1463 Val ) 1464 Dn ) ) 1465 1466 (dm val> () 1467 (let S (super) 1468 (or (format S) S) ) ) 1469 1470 1471 (class +DateField +TextField) 1472 1473 (dm txt> (Val) 1474 (datStr Val) ) 1475 1476 (dm set> (Val Dn) 1477 (super (datStr Val) Dn) ) 1478 1479 (dm val> () 1480 (expDat (super)) ) 1481 1482 (dm chk> () 1483 (and 1484 (str> This) 1485 (not (val> This)) 1486 ,"Bad date format" ) ) 1487 1488 1489 (class +TimeField +TextField) 1490 1491 (dm txt> (Val) 1492 (tim$ Val (> (: dx) 6)) ) 1493 1494 (dm set> (Val Dn) 1495 (super (tim$ Val (> (: dx) 6)) Dn) ) 1496 1497 (dm val> () 1498 ($tim (super)) ) 1499 1500 (dm chk> () 1501 (and 1502 (str> This) 1503 (not (val> This)) 1504 ,"Bad time format" ) ) 1505 1506 1507 (class +Img +gui) 1508 # img alt url dx dy 1509 1510 (dm T (Alt Url DX DY) 1511 (=: alt Alt) 1512 (=: url Url) 1513 (=: dx DX) 1514 (=: dy DY) 1515 (super) ) 1516 1517 (dm js> () 1518 (pack 1519 (ht:Fmt (sesId (or (: img) "@img/no.png"))) '& 1520 (eval (: alt)) '& 1521 (and (eval (: url)) (ht:Fmt (sesId @))) ) ) 1522 1523 (dm show> ("Var") 1524 (showFld 1525 (<img> 1526 (or (: img) "@img/no.png") 1527 (eval (: alt)) 1528 (eval (: url)) 1529 (: dx) 1530 (: dy) ) ) ) 1531 1532 (dm set> (Val Dn) 1533 (=: img Val) ) 1534 1535 (dm val> () 1536 (: img) ) 1537 1538 1539 (class +Icon) 1540 # icon url 1541 1542 (dm T (Exe Url . @) 1543 (=: icon Exe) 1544 (=: url Url) 1545 (pass extra) ) 1546 1547 (dm js> () 1548 (pack (extra) "&*" 1549 (ht:Fmt (sesId (eval (: icon)))) '& 1550 (and (eval (: url)) (ht:Fmt (sesId @))) ) ) 1551 1552 (dm show> ("Var") 1553 (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>") 1554 (extra "Var") 1555 (prin "</td><td>") 1556 (<img> (eval (: icon)) 'icon (eval (: url))) 1557 (prinl "</td></table>") ) 1558 1559 1560 (class +FileField +TextField) 1561 # file org 1562 1563 (dm T (Exe . @) 1564 (=: file Exe) 1565 (pass super) ) 1566 1567 (dm set> (Val Dn) 1568 (and 1569 (<> Val (: org)) 1570 (eval (: file)) 1571 (out @ (ctl T (prin (=: org Val)))) ) 1572 (super Val Dn) ) 1573 1574 (dm upd> () 1575 (set> This 1576 (=: org 1577 (let? F (eval (: file)) 1578 (and 1579 (info F) 1580 (in F (ctl NIL (till NIL T))) ) ) ) ) ) 1581 1582 1583 (class +Url) 1584 # url 1585 1586 (dm T (Fun . @) 1587 (=: url Fun) 1588 (pass extra) ) 1589 1590 (dm js> () 1591 (if2 (or (: dx) (: lst)) (txt> This (val> This)) 1592 (pack (extra) "&*" (ht:Fmt (sesId "@img/go.png")) '& (ht:Fmt (sesId ((: url) @)))) 1593 (pack (extra) "&*" (ht:Fmt (sesId "@img/no.png")) '&) 1594 (pack @ "&+" (ht:Fmt (sesId ((: url) @)))) 1595 (extra) ) ) 1596 1597 (dm show> ("Var") 1598 (cond 1599 ((or (: dx) (: lst)) 1600 (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>") 1601 (extra "Var") 1602 (prin "</td><td title=\"-->\">") 1603 (if (val> This) 1604 (<img> "@img/go.png" 'url ((: url) (txt> This @))) 1605 (<img> "@img/no.png") ) 1606 (prinl "</td></table>") ) 1607 ((val> This) 1608 (showFld (<href> @ ((: url) (txt> This @)))) ) 1609 (T (extra "Var")) ) ) 1610 1611 1612 (class +HttpField +Url +TextField) 1613 1614 (dm T @ 1615 (pass super 1616 '((S) (if (sub? "://" S) S (pack "http://" S))) ) ) 1617 1618 1619 (class +MailField +Url +TextField) 1620 1621 (dm T @ 1622 (pass super '((S) (pack "mailto:" S))) ) 1623 1624 1625 (class +TelField +TextField) 1626 1627 (dm txt> (Val) 1628 (telStr Val) ) 1629 1630 (dm set> (Val Dn) 1631 (super (telStr Val) Dn) ) 1632 1633 (dm val> () 1634 (expTel (super)) ) 1635 1636 (dm chk> () 1637 (and 1638 (str> This) 1639 (not (val> This)) 1640 ,"Bad phone number format" ) ) 1641 1642 1643 (class +SexField +Map +TextField) 1644 1645 (dm T (Lbl) 1646 (super 1647 '((,"male" . T) (,"female" . 0)) 1648 '(NIL ,"male" ,"female") 1649 Lbl ) ) 1650 1651 1652 (class +JsField +gui) 1653 # js str 1654 1655 (dm T (Nm) 1656 (super) 1657 (=: js Nm) ) 1658 1659 (dm show> ("Var")) 1660 1661 (dm js> () 1662 (pack (ht:Fmt NIL (: str) (: js))) ) 1663 1664 (dm set> (Val Dn) 1665 (=: str Val) ) 1666 1667 ### GUI charts ### 1668 (class +Chart) 1669 # home gui rows cols ofs lock put get data clip 1670 1671 # (cols [put [get]]) 1672 (dm T (N Put Get) 1673 (setq "*Chart" This) 1674 (queue (prop (=: home "*App") 'chart) This) 1675 (=: rows 1) 1676 (when N 1677 (=: gui (list (need (=: cols N)))) ) 1678 (=: ofs 1) 1679 (=: lock T) 1680 (=: put (or Put prog1)) 1681 (=: get (or Get prog1)) ) 1682 1683 (dm put> () 1684 (let I (: ofs) 1685 (mapc 1686 '((G D) 1687 (unless (memq NIL G) 1688 (mapc 'set> G ((: put) D I) '(T .)) ) 1689 (inc 'I) ) 1690 (: gui) 1691 (nth (: data) I) ) ) ) 1692 1693 (dm get> () 1694 (and 1695 (or (: rid) (: home able)) 1696 (not (: lock)) 1697 (let I (: ofs) 1698 (map 1699 '((G D) 1700 (set D 1701 (trim 1702 ((: get) 1703 (mapcar 'val> (car G)) 1704 (car D) 1705 (car G) ) ) ) 1706 (mapc 'set> 1707 (car G) 1708 ((: put) (car D) I) 1709 '(T .) ) 1710 (inc 'I) ) 1711 (: gui) 1712 (nth 1713 (=: data 1714 (need (- 1 I (: rows)) (: data)) ) 1715 I ) ) 1716 (=: data (trim (: data))) ) ) ) 1717 1718 (dm scroll> (N) 1719 (get> This) 1720 (unless (gt0 (inc (:: ofs) N)) 1721 (=: ofs 1) ) 1722 (put> This) ) 1723 1724 (dm goto> (N) 1725 (get> This) 1726 (=: ofs (max 1 N)) 1727 (put> This) ) 1728 1729 (dm find> ("Fun") 1730 (get> This) 1731 (let "D" (cdr (nth (: data) (: ofs))) 1732 (=: ofs 1733 (if (find "Fun" "D") 1734 (index @ (: data)) 1735 1 ) ) ) 1736 (put> This) ) 1737 1738 (dm txt> (Flg) 1739 (for (I . L) (: data) 1740 (map 1741 '((G D) 1742 (prin (txt> (car G) (car D))) 1743 (if 1744 (cdr G) 1745 (prin "^I") 1746 (prinl (and Flg "^M")) ) ) 1747 (: gui 1) 1748 ((: put) L I) ) ) ) 1749 1750 (dm set> (Lst) 1751 (=: ofs 1752 (max 1 1753 (min (: ofs) (length (=: data (copy Lst)))) ) ) 1754 (put> This) 1755 Lst ) 1756 1757 (dm log> (Lst) 1758 (=: ofs (max (: ofs) (- (length (: data)) (: rows) -2))) 1759 (set> This (conc (val> This) (cons Lst))) ) 1760 1761 (dm clr> () 1762 (set> This) ) 1763 1764 (dm val> () 1765 (get> This) 1766 (: data) ) 1767 1768 (dm init> () 1769 (upd> This) ) 1770 1771 (dm upd> ()) 1772 1773 (dm chk> ()) 1774 1775 (dm cut> (N) 1776 (get> This) 1777 (=: clip (get (val> This) (: ofs))) 1778 (set> This 1779 (remove (or N (: ofs)) (val> This)) ) ) 1780 1781 (dm paste> (Flg N) 1782 (get> This) 1783 (set> This 1784 (insert 1785 (or N (: ofs)) 1786 (val> This) 1787 (unless Flg (: clip)) ) ) ) 1788 1789 1790 (class +Chart1 +Chart) 1791 1792 # (cols) 1793 (dm T (N) 1794 (super N list car) ) 1795 1796 ### DB GUI ### 1797 (de newUrl @ 1798 (prog1 (pass new!) 1799 (lock (setq *Lock @)) 1800 (apply url (url> @ 1)) ) ) 1801 1802 1803 # (choDlg Dst Ttl Rel [Hook] [((+XyzField) ..) Exe Able [Rel2 [Hook2]]]) 1804 (de choDlg (Dst Ttl Rel . @) 1805 (let 1806 (Hook (and (meta (cdr Rel) (car Rel) 'hook) (next)) 1807 Fld (or (next) '((+TextField) 40)) 1808 Gui 1809 (if (next) 1810 (list '(+ObjView +TextField) @) 1811 (list (list '+ObjView (last (car Fld))) (list ': (car Rel))) ) 1812 Able (if (args) (next) T) ) 1813 (nond 1814 ((next) 1815 (setq Ttl (list Ttl (car Rel) (last Rel) Hook)) ) 1816 ((=T (arg)) 1817 (setq Ttl (list Ttl (car (arg)) (cadr (arg)) (next))) ) ) 1818 (diaform '(Dst Ttl Rel Hook Fld Gui Able) 1819 (apply gui 1820 (cons 1821 (cons '+Focus '+Var (car Fld)) 1822 (cdr (or (assoc Rel "*Cho") (push '"*Cho" (list Rel NIL)))) 1823 (cdr Fld) ) ) 1824 (searchButton '(init> (: home query))) 1825 (gui 'query '(+QueryChart) (cho) 1826 '(goal 1827 (list 1828 (list 'db (car Rel) (last Rel) Hook (val> (: home gui 1)) '@@) ) ) 1829 2 '((Obj) (list Obj Obj)) ) 1830 (<table> 'chart (if (atom Ttl) Ttl (apply choTtl Ttl)) '((btn) NIL) 1831 (do (cho) 1832 (<row> (alternating) 1833 (gui 1 '(+DstButton) Dst) 1834 (apply gui Gui 2) ) ) ) 1835 (<spread> 1836 (scroll (cho)) 1837 (if (meta (cdr Rel) (car Rel) 'hook) 1838 (newButton Able Dst (cdr Rel) 1839 (meta (cdr Rel) (car Rel) 'hook) 1840 Hook 1841 (car Rel) 1842 (let? Val (val> (: home gui 1)) 1843 (unless (db (car Rel) (last Rel) Hook Val) 1844 Val ) ) ) 1845 (newButton Able Dst (cdr Rel) 1846 (car Rel) 1847 (let? Val (val> (: home gui 1)) 1848 (unless (db (car Rel) (last Rel) Val) 1849 Val ) ) ) ) 1850 (cancelButton) ) ) ) ) 1851 1852 (de choTtl (Ttl Var Cls Hook) 1853 (with (or (get Cls Var) (meta Cls Var)) 1854 (if (isa '+Idx This) 1855 Ttl 1856 (pack (count (tree (: var) (: cls) Hook)) " " Ttl) ) ) ) 1857 1858 (de cho () 1859 (if (: diaform) 16 8) ) 1860 1861 1862 # Able object 1863 (class +AO +Able) 1864 # ao 1865 1866 (dm T (Exe . @) 1867 (=: ao Exe) 1868 (pass super 1869 '(and 1870 (: home obj) 1871 (not (: home obj T)) 1872 (eval (: ao)) ) ) ) 1873 1874 1875 # Lock/Edit button prefix 1876 (class +Edit +Rid +Force +Tip) 1877 # save 1878 1879 (dm T (Exe) 1880 (=: save Exe) 1881 (super 1882 '(nor (: home able) (lock (: home obj))) 1883 '(if (: home able) 1884 ,"Release exclusive write access for this object" 1885 ,"Gain exclusive write access for this object" ) 1886 '(if (: home able) ,"Done" ,"Edit") 1887 '(if (: home able) 1888 (when (able) 1889 (eval (: save)) 1890 (unless (pair "*Err") 1891 (rollback) 1892 (off *Lock) ) ) 1893 (tryLock (: home obj)) ) ) ) 1894 1895 (de tryLock (Obj) 1896 (if (lock Obj) 1897 (error (text ,"Currently edited by '@2' (@1)" @ (cdr (lup *Users @)))) 1898 (sync) 1899 (tell) 1900 (setq *Lock Obj) ) ) 1901 1902 1903 (de editButton (Able Exe) 1904 (<style> (and (: able) 'edit) 1905 (gui '(+AO +Focus +Edit +Button) Able Exe) ) ) 1906 1907 (de searchButton (Exe) 1908 (gui '(+Rid +JS +Tip +Button) ,"Start search" ,"Search" Exe) ) 1909 1910 (de resetButton (Lst) 1911 (gui '(+Force +ClrButton) T ,"Reset" Lst) ) 1912 1913 (de newButton (Able Dst . Args) 1914 (gui '(+Rid +Able +Close +Tip +Button) Able ,"Create new object" ',"New" 1915 (nond 1916 (Dst (cons 'newUrl Args)) 1917 ((pair Dst) 1918 (list 'set> (lit Dst) (cons 'new! Args)) ) 1919 (NIL 1920 (list 'prog (list '=: 'obj (cons 'new! Args)) Dst) ) ) ) ) 1921 1922 # Clone object in form 1923 (de cloneButton (Able) 1924 (gui '(+Rid +Able +Tip +Button) (or Able T) 1925 ,"Create a new copy of this object" 1926 ,"New/Copy" 1927 '(apply url 1928 (url> 1929 (prog1 1930 (clone!> (: home obj)) 1931 (lock (setq *Lock @)) ) 1932 1 ) ) ) ) 1933 1934 # Delete object in form 1935 (de delButton (Able @Txt) 1936 (gui '(+Force +Rid +Able +Tip +Button) T Able 1937 '(if (: home obj T) 1938 ,"Mark this object as \"not deleted\"" 1939 ,"Mark this object as \"deleted\"" ) 1940 '(if (: home obj T) ,"Restore" ,"Delete") 1941 (fill 1942 '(nond 1943 ((: home obj T) 1944 (ask (text ,"Delete @1?" @Txt) 1945 (lose!> (: home top 1 obj)) ) ) 1946 ((keep?> (: home obj)) 1947 (ask (text ,"Restore @1?" @Txt) 1948 (keep!> (: home top 1 obj)) ) ) 1949 (NIL 1950 (note ,"Restore" 1951 (mapcar 1952 '((X) (text "'@1' -- @2" (car X) (cdr X))) 1953 @ ) ) ) ) ) ) ) 1954 1955 1956 # Relations 1957 (class +/R +Able) 1958 # erVar erObj 1959 1960 (dm T (Lst . @) 1961 (=: erVar (car Lst)) 1962 (=: erObj (cdr Lst)) 1963 (pass super 1964 '(and (eval (: erObj)) (not (get @ T))) ) ) 1965 1966 (dm upd> () 1967 (set> This (get (eval (: erObj)) (: erVar))) ) 1968 1969 1970 # Symbol/Relation 1971 (class +S/R +/R) 1972 1973 (dm set> (Val Dn) 1974 (and 1975 (eval (: erObj)) 1976 (put! @ (: erVar) Val) ) 1977 (extra Val Dn) ) 1978 1979 1980 # Entity/Relation 1981 (class +E/R +/R) 1982 1983 (dm set> (Val Dn) 1984 (and 1985 (not (: lock)) 1986 (eval (: erObj)) 1987 (put!> @ (: erVar) Val) ) 1988 (extra Val Dn) ) 1989 1990 (dm chk> () 1991 (or 1992 (extra) 1993 (and 1994 (eval (: erObj)) 1995 (mis> @ (: erVar) (val> This)) ) ) ) 1996 1997 1998 (class +SubE/R +E/R) 1999 # sub 2000 2001 (dm T (Lst . @) 2002 (pass super 2003 (cons 2004 (pop 'Lst) 2005 (append '(: home obj) (cons (car Lst))) ) ) 2006 (=: sub Lst) 2007 (=: able (bool (: able))) ) 2008 2009 (dm set> (Val Dn) 2010 (when (and Val (not (eval (: erObj)))) 2011 (dbSync) 2012 (put> (: home obj) 2013 (: sub 1) 2014 (new (or (meta (: sub -1) 'Dbf 1) 1) (: sub -1)) ) 2015 (commit 'upd) ) 2016 (super Val Dn) ) 2017 2018 2019 (class +BlobField +/R +TextField) 2020 # org 2021 2022 (dm set> (Val Dn) 2023 (and 2024 (not (: lock)) 2025 (<> Val (: org)) 2026 (let? Obj (eval (: erObj)) 2027 (protect 2028 (when (put!> Obj (: erVar) (bool Val)) 2029 (out (blob Obj (: erVar)) 2030 (prin (=: org Val)) ) 2031 (blob+ Obj (: erVar)) ) ) ) ) 2032 (super Val Dn) ) 2033 2034 (dm upd> () 2035 (set> This 2036 (=: org 2037 (let? Obj (eval (: erObj)) 2038 (when (get Obj (: erVar)) 2039 (in (blob Obj (: erVar)) 2040 (till NIL T) ) ) ) ) ) ) 2041 2042 2043 (class +ClassField +Map +TextField) 2044 # erObj 2045 2046 (dm T (Exe Lst) 2047 (=: erObj Exe) 2048 (super Lst (mapcar car Lst)) ) 2049 2050 (dm upd> () 2051 (set> This (val (eval (: erObj)))) ) 2052 2053 (dm set> (Val Dn) 2054 (and 2055 (eval (: erObj)) 2056 (set!> @ Val) ) 2057 (super Val Dn) ) 2058 2059 2060 (class +obj) 2061 # msg obj 2062 2063 # ([T|msg] ..) 2064 (dm T () 2065 (ifn (atom (next)) 2066 (=: msg 'url>) 2067 (=: msg (arg)) 2068 (next) ) ) 2069 2070 (dm js> () 2071 (if (=T (: msg)) 2072 (extra) 2073 (if2 (or (: dx) (: lst)) (try (: msg) (: obj) 1) 2074 (pack (extra) "&*" (ht:Fmt (sesId "@img/go.png")) '& (ht:Fmt (sesId (mkUrl @)))) 2075 (pack (extra) "&*" (ht:Fmt (sesId "@img/no.png")) '&) 2076 (pack (ht:Fmt (nonblank (str> This))) "&+" (ht:Fmt (sesId (mkUrl @)))) 2077 (extra) ) ) ) 2078 2079 (dm show> ("Var") 2080 (cond 2081 ((=T (: msg)) (extra "Var")) 2082 ((or (: dx) (: lst)) 2083 (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>") 2084 (extra "Var") 2085 (prin "</td><td title=\"-->\">") 2086 (if (try (: msg) (: obj) 1) 2087 (<img> "@img/go.png" 'obj (mkUrl @)) 2088 (<img> "@img/no.png") ) 2089 (prinl "</td></table>") ) 2090 ((try (: msg) (: obj) 1) 2091 (showFld (<href> (nonblank (str> This)) (mkUrl @))) ) 2092 (T (extra "Var")) ) ) 2093 2094 2095 (class +Obj +hint +obj) 2096 # objVar objTyp objHook 2097 2098 # ([T|msg] (var . typ) [hook] [T] ..) 2099 (dm T @ 2100 (super) 2101 (=: objVar (car (arg))) 2102 (=: objTyp (cdr (arg))) 2103 (when (meta (: objTyp) (: objVar) 'hook) 2104 (=: objHook (next)) ) 2105 (pass extra 2106 (if (nT (next)) 2107 (arg) 2108 (cons NIL 2109 (if (: objHook) 2110 (collect (: objVar) (last (: objTyp)) (eval @) NIL T (: objVar)) 2111 (collect (: objVar) (last (: objTyp)) NIL T (: objVar)) ) ) ) ) ) 2112 2113 (dm hint> (Str) 2114 (dbHint (extra Str) 2115 (: objVar) 2116 (last (: objTyp)) 2117 (: objHook) ) ) 2118 2119 (dm txt> (Obj) 2120 (if (ext? Obj) 2121 (get Obj (: objVar)) 2122 Obj ) ) 2123 2124 (dm set> (Obj Dn) 2125 (extra 2126 (if (ext? (=: obj Obj)) 2127 (get Obj (: objVar)) 2128 Obj ) 2129 Dn ) ) 2130 2131 (dm val> () 2132 (let Val (extra) 2133 (cond 2134 ((and (: obj) (not (ext? @))) Val) 2135 ((= Val (get (: obj) (: objVar))) 2136 (: obj) ) 2137 ((: objTyp) 2138 (=: obj 2139 (if (: objHook) 2140 (db (: objVar) (last (: objTyp)) (eval @) Val) 2141 (db (: objVar) (last (: objTyp)) Val) ) ) ) 2142 (T Val) ) ) ) 2143 2144 (dm chk> () 2145 (or 2146 (extra) 2147 (let? S (str> This) 2148 (and 2149 (: objTyp) 2150 (not (val> This)) 2151 (<> "-" S) 2152 ,"Data not found" ) ) ) ) 2153 2154 2155 (class +ObjView +obj) 2156 # disp obj 2157 2158 # ([T|msg] exe ..) 2159 (dm T @ 2160 (super) 2161 (=: disp (arg)) 2162 (pass extra) 2163 (=: able) ) 2164 2165 (dm txt> (Obj) 2166 (let Exe (: disp) 2167 (if (ext? Obj) 2168 (with Obj (eval Exe)) 2169 Obj ) ) ) 2170 2171 (dm set> (Obj Dn) 2172 (let Exe (: disp) 2173 (extra 2174 (if (ext? (=: obj Obj)) 2175 (with Obj (eval Exe)) 2176 Obj ) 2177 Dn ) ) ) 2178 2179 (dm val> () 2180 (: obj) ) 2181 2182 2183 # DB query chart 2184 (class +QueryChart +Chart) 2185 # iniR iniq query 2186 2187 # (iniR iniQ cols [put [get]]) 2188 (dm T (R Q . @) 2189 (=: iniR R) 2190 (=: iniQ Q) 2191 (pass super) ) 2192 2193 (dm init> () 2194 (query> This (eval (: iniQ))) ) 2195 2196 (dm put> () 2197 (while 2198 (and 2199 (> (: ofs) (- (length (: data)) (max (: rows) (: iniR)))) 2200 (; (prove (: query)) @@) ) 2201 (queue (:: data) @) ) 2202 (super) ) 2203 2204 (dm txt> (Flg) 2205 (for ((I . Q) (eval (: iniQ)) (prove Q)) 2206 (map 2207 '((G D) 2208 (prin (txt> (car G) (car D))) 2209 (if (cdr G) 2210 (prin "^I") 2211 (prinl (and Flg "^M")) ) ) 2212 (: gui 1) 2213 ((: put) (; @ @@) I) ) ) ) 2214 2215 (dm all> () 2216 (make 2217 (for (Q (eval (: iniQ)) (prove Q)) 2218 (link (; @ @@)) ) ) ) 2219 2220 (dm query> (Q) 2221 (=: query Q) 2222 (set> This) ) 2223 2224 (dm sort> (Exe) 2225 (set> This 2226 (goal 2227 (list 2228 (list 'lst '@@ 2229 (by '((This) (eval Exe)) sort (val> This)) ) ) ) ) ) 2230 2231 (dm clr> () 2232 (query> This (fail)) ) 2233 2234 2235 (====) 2236 2237 # Form object 2238 (de <id> "Lst" 2239 (idObj "Lst") ) 2240 2241 (de idObj ("Lst") 2242 (with (if *PRG (: obj) (=: obj *ID)) 2243 (and (: T) (prin "[")) 2244 (for "X" (if (=T (car "Lst")) (cdr "Lst") "Lst") 2245 (ht:Prin (eval "X")) ) 2246 (and (: T) (prin "]")) ) 2247 (=: able 2248 (cond 2249 ((: obj T)) 2250 ((not (: obj))) 2251 ((=T (car "Lst")) T) 2252 ((== *Lock (: obj)) T) 2253 (*Lock (rollback) (off *Lock)) ) ) ) 2254 2255 (de panel (Able Txt Del Dlg Var Cls Hook Msg Exe) 2256 (<spread> 2257 (editButton Able Exe) 2258 (delButton 2259 (cond 2260 ((=T Able) Del) 2261 ((=T Del) Able) 2262 ((and Able Del) (list 'and Able Del)) ) 2263 (list 'text Txt (list ': 'home 'obj Var)) ) 2264 (choButton Dlg) 2265 (stepBtn Var Cls Hook Msg) ) 2266 (--) ) 2267 2268 # Standard ID form 2269 (de idForm ("Entity" "Cho" "Var" "Cls" "Able" "Del" "Lst" . "Prg") 2270 (ifn *ID 2271 (prog 2272 (<h3> NIL ,"Select" " " "Entity") 2273 (form 'dialog 2274 (if (pair "Cho") 2275 (eval @) 2276 (choDlg NIL "Cho" (list "Var" "Cls")) ) ) ) 2277 (form NIL 2278 (<h3> NIL "Entity" ": " (idObj "Lst")) 2279 (panel "Able" (pack "Entity" " '@1'") "Del" 2280 (or 2281 (pair "Cho") 2282 (list 'choDlg NIL (lit "Cho") (lit (list "Var" "Cls"))) ) 2283 "Var" "Cls" ) 2284 (run "Prg") ) ) ) 2285 2286 ### Debug ### 2287 `*Dbg 2288 (noLint 'gui) 2289 (noLint 'choDlg 'gui) 2290 (noLint 'jsForm 'action) 2291 2292 # vi:et:ts=3:sw=3