picolisp

commit 77cbd0d9452b2ac1107e078e5ae1895d79a4662a
parent b352b2979b55d3ec9148657b2bdf4a9f53c4e607
Author: Commit-Bot <unknown>
Date:   Sun, 16 May 2010 16:03:37 +0000

Automatic commit from picoLisp.tgz, From: Sun, 16 May 2010 13:03:37 GMT
Diffstat:
M
lib/scrape.l
 | 
38
++++++++++++++++++++++++++++----------
M
src64/version.l
 | 
4
++--

2 files changed, 30 insertions(+), 12 deletions(-)
diff --git a/lib/scrape.l b/lib/scrape.l
@@ -1,15 +1,16 @@
-# 30apr10abu
+# 16may10abu
 # (c) Software Lab. Alexander Burger
 
-# *ScrHost *ScrPort *Title *Expect *Found
+# *ScrHost *ScrPort *ScrGate *Title *Expect *Found
 # *Links *Forms *Buttons *Fields *Errors
 
 # Scrape HTML form(s)
 (de scrape (Host Port How)
    (client (setq *ScrHost Host) (setq *ScrPort Port) How
-      (off *Links *Forms *Buttons *Fields *Errors)
+      (off *ScrGate *Links *Forms *Buttons *Fields *Errors)
       (while
          (from
+            "303 See Other"
             "<title>"
             "<base href=\"http://"
             "<a href=\""
@@ -25,15 +26,30 @@
             "<div class=\"err\">"
             *Expect )
          (case @
+            ("303 See Other"
+               (when (from "Location: http://")
+                  (let L (split (line) ':)
+                     (if (cdr L)
+                        (scrape
+                           (pack (pop 'L))
+                           (ifn (format (car (setq L (split (car L) '/))))
+                              80
+                              (pop 'L)
+                              @ )
+                           (glue '/ L) )
+                        (setq L (split (car L) '/))
+                        (scrape (pack (pop 'L)) 80 (glue '/ L)) ) ) ) )
             ("<title>"
                (setq *Title (ht:Pack (till "<"))) )
             ("<base href=\"http://"
-               (setq
-                  *ScrHost (rot (cdr (rot (split (till "\"") '/ ':))))
-                  *ScrPort (format (pop '*ScrHost))
-                  *ScrHost (pack *ScrHost) ) )
+               (let L (split (till "\"") ':)
+                  (if (cdr L)
+                     (setq
+                        *ScrHost (pack (pop 'L))
+                        *ScrPort (format (cdr (rot (car L)))) )
+                     (setq *ScrGate (pack (cdr (member '/ (car L))))) ) ) )
             ("<a href=\""
-               (let Url (till "\"" T)
+               (let Url (pack *ScrGate (till "\"" T))
                   (from ">")
                   (cond
                      ((till "<")
@@ -42,7 +58,8 @@
                         (from "alt=\"")
                         (queue '*Links (cons (ht:Pack (till "\"")) Url)) ) ) ) )
             (" action=\""
-               (queue '*Forms (list (till "\"" T))) )  # (action . fields)
+               (queue '*Forms  # (action . fields)
+                  (list (pack *ScrGate (till "\"" T))) ) )
             ("<input type=\"submit\" name=\""
                (let Nm (till "\"" T)
                   (from "value=\"")
@@ -120,7 +137,7 @@
 (de enter (Fld Str Cnt)
    (con (field Fld Cnt) Str) )
 
-### Utilities ###
+# Inspect current page
 (de display ()
    (prinl "###############")
    (apply println (mapcar car *Links) 'click)
@@ -131,6 +148,7 @@
    (prinl)
    *Title )
 
+### Utility functions ###
 (de target (Lst Lbl Cnt)
    (cond
       ((num? Lbl)
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 14may10abu
+# 16may10abu
 # (c) Software Lab. Alexander Burger
 
-(de *Version 3 0 2 20)
+(de *Version 3 0 2 21)
 
 # vi:et:ts=3:sw=3