misc.l (13525B)
1 # 11nov12abu 2 # (c) Software Lab. Alexander Burger 3 4 # *Allow *Tmp 5 6 (de *Day . (Mon Tue Wed Thu Fri Sat Sun .)) 7 (de *Mon . (Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec .)) 8 (de *mon . (jan feb mar apr may jun jul aug sep oct nov dec .)) 9 10 ### Locale ### 11 (de *Ctry) 12 (de *Lang) 13 (de *Sep0 . ".") 14 (de *Sep3 . ",") 15 (de *CtryCode) 16 (de *DateFmt @Y "-" @M "-" @D) 17 (de *DayFmt "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") 18 (de *MonFmt "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") 19 20 (de locale (Ctry Lang . @) # "DE" "de" ["app/loc/" ..] 21 (load (if (setq *Ctry Ctry) (pack "@loc/" @ ".l") "@loc/NIL.l")) 22 (ifn (setq *Lang Lang) 23 (for S (idx '*Uni) 24 (set S S) ) 25 (let L 26 (sort 27 (make 28 ("loc" (pack "@loc/" Lang)) 29 (while (args) 30 ("loc" (pack (next) Lang)) ) ) ) 31 (balance '*Uni L T) 32 (for S L 33 (set (car (idx '*Uni S)) (val S)) ) ) ) ) 34 35 (de "loc" (F) 36 (in F 37 (use X 38 (while (setq X (read)) 39 (if (=T X) 40 ("loc" (read)) 41 (set (link @) (name (read))) ) ) ) ) ) 42 43 ### String ### 44 (de align (X . @) 45 (pack 46 (if (pair X) 47 (mapcar 48 '((X) (need X (chop (next)) " ")) 49 X ) 50 (need X (chop (next)) " ") ) ) ) 51 52 (de center (X . @) 53 (pack 54 (if (pair X) 55 (let R 0 56 (mapcar 57 '((X) 58 (let (S (chop (next)) N (>> 1 (+ X (length S)))) 59 (prog1 60 (need (+ N R) S " ") 61 (setq R (- X N)) ) ) ) 62 X ) ) 63 (let S (chop (next)) 64 (need (>> 1 (+ X (length S))) S " ") ) ) ) ) 65 66 (de wrap (Max Lst) 67 (setq Lst (split Lst " " "^J")) 68 (pack 69 (make 70 (while Lst 71 (if (>= (length (car Lst)) Max) 72 (link (pop 'Lst) "^J") 73 (chain 74 (make 75 (link (pop 'Lst)) 76 (loop 77 (NIL Lst) 78 (T (>= (+ (length (car Lst)) (sum length (made))) Max) 79 (link "^J") ) 80 (link " " (pop 'Lst)) ) ) ) ) ) ) ) ) 81 82 ### Number ### 83 (de pad (N Val) 84 (pack (need N (chop Val) "0")) ) 85 86 (de money (N Cur) 87 (if Cur 88 (pack (format N 2 *Sep0 *Sep3) " " Cur) 89 (format N 2 *Sep0 *Sep3) ) ) 90 91 (de round (N D) 92 (if (> *Scl (default D 3)) 93 (format (*/ N (** 10 (- *Scl D))) D *Sep0 *Sep3) 94 (format N *Scl *Sep0 *Sep3) ) ) 95 96 # Binary notation 97 (de bin (X I) 98 (cond 99 ((num? X) 100 (let (S (and (lt0 X) '-) L (& 1 X) A (cons 0 I)) 101 (until (=0 (setq X (>> 1 X))) 102 (at A (push 'L " ")) 103 (push 'L (& 1 X)) ) 104 (pack S L) ) ) 105 ((setq X (filter '((C) (not (sp? C))) (chop X))) 106 (let (S (and (= '- (car X)) (pop 'X)) N 0) 107 (for C X 108 (setq N (| (format C) (>> -1 N))) ) 109 (if S (- N) N) ) ) ) ) 110 111 # Octal notation 112 (de oct (X I) 113 (cond 114 ((num? X) 115 (let (S (and (lt0 X) '-) L (& 7 X) A (cons 0 I)) 116 (until (=0 (setq X (>> 3 X))) 117 (at A (push 'L " ")) 118 (push 'L (& 7 X)) ) 119 (pack S L) ) ) 120 ((setq X (filter '((C) (not (sp? C))) (chop X))) 121 (let (S (and (= '- (car X)) (pop 'X)) N 0) 122 (for C X 123 (setq N (| (format C) (>> -3 N))) ) 124 (if S (- N) N) ) ) ) ) 125 126 # Hexadecimal notation 127 (de hex (X I) 128 (cond 129 ((num? X) 130 (let (S (and (lt0 X) '-) L (hex1 X) A (cons 0 I)) 131 (until (=0 (setq X (>> 4 X))) 132 (at A (push 'L " ")) 133 (push 'L (hex1 X)) ) 134 (pack S L) ) ) 135 ((setq X (filter '((C) (not (sp? C))) (chop X))) 136 (let (S (and (= '- (car X)) (pop 'X)) N 0) 137 (for C X 138 (setq C (- (char C) `(char "0"))) 139 (and (> C 9) (dec 'C 7)) 140 (and (> C 22) (dec 'C 32)) 141 (setq N (| C (>> -4 N))) ) 142 (if S (- N) N) ) ) ) ) 143 144 (de hex1 (N) 145 (let C (& 15 N) 146 (and (> C 9) (inc 'C 7)) 147 (char (+ C `(char "0"))) ) ) 148 149 # Hexadecimal/Alpha notation 150 (de hax (X) 151 (if (num? X) 152 (pack 153 (mapcar 154 '((C) 155 (when (> (setq C (- (char C) `(char "0"))) 9) 156 (dec 'C 7) ) 157 (char (+ `(char "@") C)) ) 158 (chop (hex X)) ) ) 159 (hex 160 (mapcar 161 '((C) 162 (when (> (setq C (- (char C) `(char "@"))) 9) 163 (inc 'C 7) ) 164 (char (+ `(char "0") C)) ) 165 (chop X) ) ) ) ) 166 167 # Base 64 notation 168 (de fmt64 (X) 169 (if (num? X) 170 (let L (_fmt64 X) 171 (until (=0 (setq X (>> 6 X))) 172 (push 'L (_fmt64 X)) ) 173 (pack L) ) 174 (let N 0 175 (for C (chop X) 176 (setq C (- (char C) `(char "0"))) 177 (and (> C 42) (dec 'C 6)) 178 (and (> C 11) (dec 'C 5)) 179 (setq N (+ C (>> -6 N))) ) 180 N ) ) ) 181 182 (de _fmt64 (N) 183 (let C (& 63 N) 184 (and (> C 11) (inc 'C 5)) 185 (and (> C 42) (inc 'C 6)) 186 (char (+ C `(char "0"))) ) ) 187 188 ### Tree ### 189 (de balance ("Var" "Lst" "Flg") 190 (unless "Flg" (set "Var")) 191 (let "Len" (length "Lst") 192 (recur ("Lst" "Len") 193 (unless (=0 "Len") 194 (let ("N" (>> 1 (inc "Len")) "L" (nth "Lst" "N")) 195 (idx "Var" (car "L") T) 196 (recurse "Lst" (dec "N")) 197 (recurse (cdr "L") (- "Len" "N")) ) ) ) ) ) 198 199 (de depth (Idx) #> (max . average) 200 (let (C 0 D 0 N 0) 201 (cons 202 (recur (Idx N) 203 (ifn Idx 204 0 205 (inc 'C) 206 (inc 'D (inc 'N)) 207 (inc 208 (max 209 (recurse (cadr Idx) N) 210 (recurse (cddr Idx) N) ) ) ) ) 211 (or (=0 C) (*/ D C)) ) ) ) 212 213 ### Allow ### 214 (de allowed Lst 215 (setq *Allow (cons NIL (car Lst))) 216 (balance *Allow (sort (cdr Lst))) ) 217 218 (de allow (X Flg) 219 (nond 220 (*Allow) 221 (Flg (idx *Allow X T)) 222 ((member X (cdr *Allow)) (queue '*Allow X)) ) 223 X ) 224 225 ### Telephone ### 226 (de telStr (S) 227 (cond 228 ((not S)) 229 ((and *CtryCode (pre? (pack *CtryCode " ") S)) 230 (pack 0 (cdddr (chop S))) ) 231 (T (pack "+" S)) ) ) 232 233 (de expTel (S) 234 (setq S 235 (make 236 (for (L (chop S) L) 237 (ifn (sub? (car L) " -") 238 (link (pop 'L)) 239 (let F NIL 240 (loop 241 (and (= '- (pop 'L)) (on F)) 242 (NIL L) 243 (NIL (sub? (car L) " -") 244 (link (if F '- " ")) ) ) ) ) ) ) ) 245 (cond 246 ((= "+" (car S)) (pack (cdr S))) 247 ((head '("0" "0") S) 248 (pack (cddr S)) ) 249 ((and *CtryCode (= "0" (car S))) 250 (pack *CtryCode " " (cdr S)) ) ) ) 251 252 ### Date ### 253 # ISO date 254 (de dat$ (Dat C) 255 (when (date Dat) 256 (pack (car @) C (pad 2 (cadr @)) C (pad 2 (caddr @))) ) ) 257 258 (de $dat (S C) 259 (if C 260 (and 261 (= 3 262 (length (setq S (split (chop S) C))) ) 263 (date 264 (format (car S)) # Year 265 (or (format (cadr S)) 0) # Month 266 (or (format (caddr S)) 0) ) ) # Day 267 (and 268 (format S) 269 (date 270 (/ @ 10000) # Year 271 (% (/ @ 100) 100) # Month 272 (% @ 100) ) ) ) ) 273 274 (de datSym (Dat) 275 (when (date Dat) 276 (pack 277 (pad 2 (caddr @)) 278 (get *mon (cadr @)) 279 (pad 2 (% (car @) 100)) ) ) ) 280 281 # Localized 282 (de datStr (D F) 283 (when (setq D (date D)) 284 (let 285 (@Y (if F (pad 2 (% (car D) 100)) (pad 4 (car D))) 286 @M (pad 2 (cadr D)) 287 @D (pad 2 (caddr D)) ) 288 (pack (fill *DateFmt)) ) ) ) 289 290 (de strDat (S) 291 (use (@Y @M @D) 292 (and 293 (match *DateFmt (chop S)) 294 (date 295 (format @Y) 296 (or (format @M) 0) 297 (or (format @D) 0) ) ) ) ) 298 299 (de expDat (S) 300 (use (@Y @M @D X) 301 (unless (match *DateFmt (setq S (chop S))) 302 (if 303 (or 304 (cdr (setq S (split S "."))) 305 (>= 2 (length (car S))) ) 306 (setq 307 @D (car S) 308 @M (cadr S) 309 @Y (caddr S) ) 310 (setq 311 @D (head 2 (car S)) 312 @M (head 2 (nth (car S) 3)) 313 @Y (nth (car S) 5) ) ) ) 314 (and 315 (setq @D (format @D)) 316 (date 317 (nond 318 (@Y (car (date (date)))) 319 ((setq X (format @Y))) 320 ((>= X 100) 321 (+ X 322 (* 100 (/ (car (date (date))) 100)) ) ) 323 (NIL X) ) 324 (nond 325 (@M (cadr (date (date)))) 326 ((setq X (format @M)) 0) 327 ((n0 X) (cadr (date (date)))) 328 (NIL X) ) 329 @D ) ) ) ) 330 331 # Day of the week 332 (de day (Dat Lst) 333 (get 334 (or Lst *DayFmt) 335 (inc (% (inc Dat) 7)) ) ) 336 337 # Week of the year 338 (de week (Dat) 339 (let W 340 (- 341 (_week Dat) 342 (_week (date (car (date Dat)) 1 4)) 343 -1 ) 344 (if (=0 W) 53 W) ) ) 345 346 (de _week (Dat) 347 (/ (- Dat (% (inc Dat) 7)) 7) ) 348 349 # Last day of month 350 (de ultimo (Y M) 351 (dec 352 (if (= 12 M) 353 (date (inc Y) 1 1) 354 (date Y (inc M) 1) ) ) ) 355 356 ### Time ### 357 (de tim$ (Tim F) 358 (when Tim 359 (setq Tim (time Tim)) 360 (pack (pad 2 (car Tim)) ":" (pad 2 (cadr Tim)) 361 (and F ":") 362 (and F (pad 2 (caddr Tim))) ) ) ) 363 364 (de $tim (S) 365 (setq S (split (chop S) ":")) 366 (unless (or (cdr S) (>= 2 (length (car S)))) 367 (setq S 368 (list 369 (head 2 (car S)) 370 (head 2 (nth (car S) 3)) 371 (nth (car S) 5) ) ) ) 372 (when (format (car S)) 373 (time @ 374 (or (format (cadr S)) 0) 375 (or (format (caddr S)) 0) ) ) ) 376 377 (de stamp (Dat Tim) 378 (and (=T Dat) (setq Dat (date T))) 379 (default Dat (date) Tim (time T)) 380 (pack (dat$ Dat "-") " " (tim$ Tim T)) ) 381 382 ### I/O ### 383 (de chdir ("Dir" . "Prg") 384 (let? "Old" (cd "Dir") 385 (finally (cd "Old") 386 (run "Prg") ) ) ) 387 388 (de dirname (F) 389 (pack (flip (member '/ (flip (chop F))))) ) 390 391 (de basename (F) 392 (pack (stem (chop F) '/)) ) 393 394 # Print or eval 395 (de prEval (Prg Ofs) 396 (default Ofs 1) 397 (for X Prg 398 (if (atom X) 399 (prinl (eval X Ofs)) 400 (eval X Ofs) ) ) ) 401 402 # Echo here-documents 403 (de here (S) 404 (line) 405 (echo S) ) 406 407 # Send mail 408 (de mail (Host Port From To Sub Att . Prg) 409 (let? S (connect Host Port) 410 (let B (pack "==" (date) "-" (time T) "==") 411 (prog1 412 (and 413 (pre? "220 " (in S (line T))) 414 (out S (prinl "HELO " (cdr (member "@" (chop From))) "^M")) 415 (pre? "250 " (in S (line T))) 416 (out S (prinl "MAIL FROM:" From "^M")) 417 (pre? "250 " (in S (line T))) 418 (if (atom To) 419 (_rcpt To) 420 (find bool (mapcar _rcpt To)) ) 421 (out S (prinl "DATA^M")) 422 (pre? "354 " (in S (line T))) 423 (out S 424 (prinl "From: " From "^M") 425 (prinl "To: " (or (fin To) (glue "," To)) "^M") 426 (prinl "Subject: " Sub "^M") 427 (prinl "User-Agent: PicoLisp^M") 428 (prinl "MIME-Version: 1.0^M") 429 (when Att 430 (prinl "Content-Type: multipart/mixed; boundary=\"" B "\"^M") 431 (prinl "^M") 432 (prinl "--" B "^M") ) 433 (prinl "Content-Type: text/plain; charset=utf-8^M") 434 (prinl "Content-Transfer-Encoding: 8bit^M") 435 (prinl "^M") 436 (prEval Prg 2) 437 (prinl "^M") 438 (when Att 439 (loop 440 (prinl "--" B "^M") 441 (prinl 442 "Content-Type: " 443 (or (caddr Att) "application/octet-stream") 444 "; name=\"" 445 (cadr Att) 446 "\"^M" ) 447 (prinl "Content-Transfer-Encoding: base64^M") 448 (prinl "^M") 449 (in (car Att) 450 (while 451 (do 15 452 (NIL (ext:Base64 (rd 1) (rd 1) (rd 1))) 453 T ) 454 (prinl) ) ) 455 (prinl) 456 (prinl "^M") 457 (NIL (setq Att (cdddr Att))) ) 458 (prinl "--" B "--^M") ) 459 (prinl ".^M") 460 (prinl "QUIT^M") ) 461 T ) 462 (close S) ) ) ) ) 463 464 (de _rcpt (To) 465 (out S (prinl "RCPT TO:" To "^M")) 466 (pre? "250 " (in S (line T))) ) 467 468 ### Debug ### 469 `*Dbg 470 471 # Hex Dump 472 (de hd (File Cnt) 473 (in File 474 (let Pos 0 475 (while 476 (and 477 (nand Cnt (lt0 (dec 'Cnt))) 478 (make (do 16 (and (rd 1) (link @)))) ) 479 (let L @ 480 (prin (pad 8 (hex Pos)) " ") 481 (inc 'Pos 16) 482 (for N L 483 (prin (pad 2 (hex N)) " ") ) 484 (space (inc (* 3 (- 16 (length L))))) 485 (for N L 486 (prin (if (>= 126 N 32) (char N) ".")) ) 487 (prinl) ) ) ) ) ) 488 489 # vi:et:ts=3:sw=3