1; This file contains the lisp library code for the Munger interpreter. 2 3; Copyright (c) 2001, 2002, 2003, James Bailie <jimmy@mammothcheese.ca>. 4; All rights reserved. 5; 6; Redistribution and use in source form, with or without 7; modification, are permitted provided that the following conditions are met: 8; 9; * Redistributions of source code must retain the above copyright 10; notice, this list of conditions and the following disclaimer. 11; * The name of James Bailie may not be used to endorse or promote 12; products derived from this software without specific prior written permission. 13; 14; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" 15; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 18; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 19; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 20; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 21; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 22; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 23; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 24; POSSIBILITY OF SUCH DAMAGE. 25 26(set 'caar (lambda (x) (car (car x)))) 27(set 'cdar (lambda (x) (cdr (car x)))) 28(set 'cadr (lambda (x) (car (cdr x)))) 29(set 'cddr (lambda (x) (cdr (cdr x)))) 30(set 'caddr (lambda (x) (car (cdr (cdr x))))) 31(set 'cdddr (lambda (x) (cdr (cdr (cdr x))))) 32(set 'cadddr (lambda (x) (car (cdr (cdr (cdr x)))))) 33(set 'cddddr (lambda (x) (cdr (cdr (cdr (cdr x)))))) 34(set 'caddddr (lambda (x) (car (cdr (cdr (cdr (cdr x))))))) 35 36(set 'nullp (lambda (x) (eq x ()))) 37(set 'pairp (lambda (x) (and (not (atomp x)) (not (nullp x))))) 38 39(set 'equal 40 (lambda (x y) 41 (if (eq x y) 42 1 43 (and (pairp x) 44 (pairp y) 45 (equal (car x) (car y)) 46 (equal (cdr x) (cdr y)))))) 47 48(set 'reverse 49 (lambda (x) 50 (if (stringp x) 51 (join "" (reverse (split "" x))) 52 53 (if (pairp x) 54 (append (reverse (cdr x)) (list (car x))) 55 ())))) 56 57(set 'remove 58 (lambda (y x) 59 (if (not (pairp x)) 60 x 61 (if (equal (car x) y) 62 (remove y (cdr x)) 63 (cons (car x) (remove y (cdr x))))))) 64 65(set 'alist_lookup 66 (lambda (x y) 67 (if (not (pairp y)) 68 () 69 (catch 70 (while y 71 (if (equal (caar y) x) 72 (throw (cdar y)) 73 (set 'y (cdr y)))))))) 74 75(set 'alist_remove 76 (lambda (x y) 77 (let ((z y)) 78 (catch 79 (while y 80 (if (equal (caar y) x) 81 (throw (remove (car y) z))) 82 (set 'y (cdr y))) 83 z)))) 84 85(set 'alist_replace 86 (lambda (x y z) 87 88 (let ((w y)) 89 (catch 90 (while y 91 (if (equal (caar y) x) 92 (throw (cons (cons x z) (remove (car y) w)))) 93 (set 'y (cdr y))) 94 95 (cons (cons x z) w))))) 96 97(set 'upcase 98 (lambda (s a) 99 (when s 100 (let ((x 1)) 101 102 (join "" 103 (mapcar 104 (lambda (c) 105 (let ((d (code c))) 106 (if (not (and x (<= d 122) (>= d 97))) 107 c 108 (when (not a) (setq x 0)) 109 (char (- d 32))))) 110 111 (split "" s))))))) 112 113(set 'downcase 114 (lambda (s a) 115 (when s 116 (let ((x 1)) 117 118 (join "" 119 (mapcar 120 (lambda (c) 121 (let ((d (code c))) 122 (if (not (and x (<= d 90) (>= d 65))) 123 c 124 (when (not a) (setq x 0)) 125 (char (+ d 32))))) 126 127 (split "" s))))))) 128 129(setq mapcar 130 (lambda (f l) 131 (when l 132 (let ((n ())) 133 (while l 134 (setq n (cons (f (car l)) n)) 135 (setq l (cdr l))) 136 (reverse n))))) 137 138(set 'map 139 (lambda (f l (more)) 140 (if (not more) 141 (mapcar f l) 142 143 (letf map_more ((l l) 144 (more more)) 145 146 (when l 147 (cons (eval (cons f (cons (car l) (map car more)))) 148 (map_more (cdr l) (map cdr more)))))))) 149 150(set 'foreach 151 (lambda (f l) 152 (while l 153 (f (car l)) 154 (setq l (cdr l))))) 155 156(set 'member 157 (lambda (x l) 158 (if (not l) 159 0 160 (if (equal (car l) x) 161 1 162 (member x (cdr l)))))) 163 164(set 'apply 165 (macro (a b) 166 (list 'eval (list 'cons a b)))) 167 168(set 'quit (macro () '(exit 0))) 169 170(set 'qquote 171 (macro (args) 172 (labels ((buildit 173 (lambda (args) 174 (and args 175 (cons (cond ((eq (car args) ',) 176 (car (set 'args (cdr args)))) 177 178 ((pairp (car args)) 179 (cons 'list (buildit (car args)))) 180 181 (1 (list 'quote (car args)))) 182 183 (buildit (cdr args))))))) 184 185 (cons 'list (buildit args))))) 186 187(set 'with_input_file 188 (macro (file (code)) 189 (qquote 190 (when (> (redirect 0 ,file) 0) 191 (protect ,(cons 'progn code) 192 (resume 0)))))) 193 194(set 'with_output_file 195 (macro (file (code)) 196 (qquote 197 (when (> (redirect 1 ,file) 0) 198 (protect ,(cons 'progn code) 199 (resume 1)))))) 200 201(set 'with_error_file 202 (macro (file (code)) 203 (qquote 204 (when (> (redirect 2 ,file) 0) 205 (protect ,(cons 'progn code) 206 (resume 2)))))) 207 208(let ((r (gensym))) 209 210 (set 'with_error_file_appending 211 (macro (file (code)) 212 (qquote 213 (let ((,r 0)) 214 (if (> (setq ,r (redirect 2 ,file 1)) 0) 215 (protect ,(cons 'progn code) 216 (resume 2)) 217 ,r)))))) 218 219(let ((r (gensym))) 220 221 (set 'with_output_file_appending 222 (macro (file (code)) 223 (qquote 224 (let ((,r 0)) 225 (if (> (setq ,r (redirect 1 ,file 1)) 0) 226 (protect ,(cons 'progn code) 227 (resume 1)) 228 ,r)))))) 229 230(set 'with_input_process 231 (macro (cmd (code)) 232 (qquote 233 (progn 234 (pipe 0 ,cmd) 235 (protect ,(cons 'progn code) 236 (resume 0)))))) 237 238(set 'with_output_process 239 (macro (cmd (code)) 240 (qquote 241 (progn 242 (pipe 1 ,cmd) 243 (protect ,(cons 'progn code) 244 (resume 1)))))) 245 246(let ((line (gensym))) 247 248 (set 'foreach_line 249 (macro (func) 250 251 (qquote 252 (if (not (next)) 253 (while (set (quote ,line) (getline)) 254 (,func ,line)) 255 256 (do 257 (when (> (redirect 0 (current)) 0) 258 (while (set (quote ,line) (getline)) 259 (,func ,line))) 260 (next)) 261 262 (resume 0)))))) 263 264(let ((line (gensym))) 265 266 (set 'foreach_line_callback 267 (macro (func callback (after)) 268 269 (qquote 270 (if (not (next)) 271 (progn 272 (while (set (quote ,line) (getline)) 273 (,func ,line)) 274 (,callback)) 275 276 (do 277 (when (> (redirect 0 (current)) 0) 278 (while (set (quote ,line) (getline)) 279 (,func ,line))) 280 281 ,(if (and after (car after)) 282 (qquote 283 (prog1 284 (next) 285 (,callback))) 286 287 (qquote 288 (progn 289 (,callback) 290 (next))))) 291 292 (resume 0)))))) 293 294(set 'assign 295 (lambda (s l) 296 297 (let ((n 0) 298 (len (length l))) 299 300 (progn 301 (while (< (used s) len) 302 (push s ())) 303 304 (while l 305 (store s n (car l)) 306 (inc n) 307 (set 'l (cdr l))) 308 309 s)))) 310 311(set 'flatten 312 (lambda (s) 313 314 (let ((r ()) 315 (i (used s))) 316 317 (progn 318 (while i 319 (set 'r (cons (index s (dec i)) r))) 320 321 r)))) 322 323(let ((buff (gensym))) 324 325 (set 'with_buffer 326 (macro (x (y)) 327 328 (qquote 329 (let ((,buff (buffer))) 330 (switch ,x) 331 (protect ,(cons 'progn y) 332 (switch ,buff))))))) 333 334(set 'defun 335 (macro (name args (body)) 336 (qquote 337 (set (quote ,name) 338 ,(cons 'lambda (cons args body)))))) 339 340(set 'defmac 341 (macro (name args (body)) 342 (qquote 343 (set (quote ,name) 344 ,(cons 'macro (cons args body)))))) 345 346(defmac letf (name args (body)) 347 (qquote 348 (labels ((,name ,(append (list 'lambda (mapcar car args)) body))) 349 ,(cons name (mapcar cadr args))))) 350 351(let ((r (gensym))) 352 353 (defmac prog1 ((args)) 354 (when args 355 (qquote 356 (let ((,r 0)) 357 (setq ,r ,(car args)) 358 ,(cons 'progn (cdr args)) 359 ,r))))) 360 361(defmac concat ((args)) 362 (cons 'join (cons "" args))) 363 364(defmac explode (arg) 365 (list 'split "" arg)) 366 367(defun split_rx (rx arg (limit)) 368 369 (let ((m (match rx arg)) 370 (limit (if limit (- (abs (car limit)) 1) -1)) 371 (r ())) 372 373 (if (not m) 374 (list arg) 375 376 (catch 377 (while (and limit m) 378 (when (car m) 379 (dec limit) 380 (setq r (cons (substring arg 0 (car m)) r))) 381 382 (when (eq (length arg) (cadr m)) 383 (throw (reverse r))) 384 385 (setq arg (substring arg (cadr m) 0)) 386 (setq m (match rx arg))) 387 388 (reverse (cons arg r)))))) 389 390(let ((rx (regcomp (concat "[\b\t" (char 10) (char 13) "]+")))) 391 (defun tokenize (arg) 392 (split_rx rx arg))) 393 394(let ((m (gensym)) 395 (i (gensym)) 396 (l (gensym)) 397 (r (gensym)) 398 (c (gensym)) 399 (p (gensym))) 400 401 (defmac replace (rx expr str (limit)) 402 (qquote 403 404 (let ((,m (matches ,rx ,str)) 405 (,i -1) 406 (,l "") 407 (,r "") 408 (,c 0) 409 (,p ())) 410 411 (if (not ,m) 412 ,str 413 414 (setq ,p ,m) 415 (while ,p 416 (extend (intern (stringify "m" (inc ,i))) (car ,p)) 417 (setq ,p (cdr ,p))) 418 419 (setq ,l ,str) 420 (setq ,c (if (quote ,limit) (+ 1 (car (quote ,limit))) -1)) 421 422 (catch 423 (while (and (dec ,c) ,m) 424 (setq ,p (match ,rx ,l)) 425 426 (setq ,r 427 (concat ,r 428 (if (car ,p) (substring ,l 0 (car ,p)) "") 429 (substitute ,rx 430 ,expr 431 (if (cadr ,p) (substring ,l (car ,p) (- (cadr ,p) (car ,p))) "") 432 1))) 433 434 (when (eq (cadr ,p) (length ,l)) 435 (throw ,r)) 436 437 (setq ,l (substring ,l (cadr ,p) 0)) 438 (setq ,m (matches ,rx ,l)) 439 440 (setq ,i -1) 441 (foreach (lambda (x) (set (intern (stringify "m" (inc ,i))) x)) ,m)) 442 443 (concat ,r ,l))))))) 444 445(let ((root_rx (regcomp "^(.*)(\.[^.]*)$"))) 446 447 (defun rootname (str) 448 (substitute root_rx "\1" str)) 449 450 (defun suffix (str) 451 (substitute root_rx "\2" str))) 452 453(defmac case (expr (clauses)) 454 455 (let ((c (gensym)) (l ())) 456 457 (while clauses 458 (setq l (cons (cons (if (eq (caar clauses) '?) 1 (list 'eq (caar clauses) c)) 459 (cdar clauses)) 460 l)) 461 (setq clauses (cdr clauses))) 462 463 (qquote 464 (let ((,c ,expr)) 465 ,(cons 'cond (reverse l)))))) 466 467(defun getstring (cmd) 468 (let ((line "") (str "")) 469 (with_input_process cmd 470 (while (setq line (getline)) 471 (setq str (concat str line))) 472 str))) 473 474(defun filter_server (start end server port) 475 (when (>= (buffer) 0) 476 477 (let ((last (lastline)) (line "") (lines (stack)) (tmp "") (idx 0) 478 (count 0) 479 (rx (regcomp (concat "^[^" (char 10) "]*" (char 10))))) 480 481 (when (and (> start 0) (> end 0) (<= start last) (<= end last) 482 (child_open server port)) 483 484 (for (n start end) 485 (child_write (retrieve n))) 486 487 (while (setq line (child_read)) 488 (push lines line)) 489 490 (child_close) 491 492 (for (((setq idx end) (setq tmp "")) 493 ((setq line (shift lines)) (when tmp (inc count) (insert idx tmp 1))) 494 ((setq tmp line))) 495 496 (setq line (concat tmp line)) 497 498 (while (setq last (match rx line)) 499 (insert idx (substring line (car last) (- (cadr last) (car last))) 1) 500 (inc idx) 501 (inc count) 502 (setq line (if (> (length line) (cadr last)) (substring line (cadr last) 0) "")))) 503 504 (for (n start end) 505 (delete start)) 506 507 count)))) 508 509(let ((blank_rx (regcomp (join "" "^[" (char 13) (char 10) "]+$"))) 510 (chunked_rx (regcomp "^Transfer-Encoding: chunked")) 511 (count_rx (regcomp "[0-9A-Fa-f]+")) 512 (count 0) 513 (f ()) 514 (idx 1)) 515 516 (defun remove_http_stuff () 517 518 (when (lastline) 519 520 ; Find the end of the HTTP header. 521 522 (setq f (find 1 1 0 blank_rx 0)) 523 (setq idx (car f)) 524 525 ; Search the header for a Transfer-Encoding: chunked header line. 526 527 (setq f (find -1 idx 0 chunked_rx 0)) 528 529 ; Delete the HTTP header. 530 531 (for (n 1 idx) (delete 1)) 532 533 ; If data in chunks, merge them. 534 535 (when (car f) 536 (setq idx 1) 537 538 (while (and (<= idx (lastline)) 539 (setq count (hex2dec (car (matches count_rx (retrieve idx)))))) 540 (delete idx) 541 542 (while (and count (<= idx (lastline))) 543 (setq count (- count (car (slice idx 0 0 1 1)))) 544 (inc idx)) 545 546 (when (<= idx (lastline)) 547 (delete idx))) 548 549 (while (<= idx (lastline)) 550 (delete idx)))))) 551 552(let ((g (gensym))) 553 (defmac with_temporary_output_file ((exprs)) 554 (qquote 555 (let ((,g (temporary))) 556 (protect 557 ,(cons 'progn exprs) 558 (resume 1)) 559 ,g)))) 560