commit 72c501a04c4b123b755acd30cc4b1dd7fede6043
parent 662edcf44c7f123e33e220e9ee4fa87fc926d28b
Author: Commit-Bot <unknown>
Date: Mon, 9 Aug 2010 08:39:16 +0000
Automatic commit from picoLisp.tgz, From: Mon, 09 Aug 2010 08:39:16 GMT
Diffstat:
16 files changed, 179 insertions(+), 91 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* XXsep10 picoLisp-3.0.4
+ Drag & Drop file upload
Generic 'lisp' C-callbacks
'native' fixpoint handling
OpenGL (64-bit) in "lib/openGl.l"
diff --git a/app/item.l b/app/item.l
@@ -1,4 +1,4 @@
-# 03jan09abu
+# 09aug10abu
# (c) Software Lab. Alexander Burger
(must "Item" Item)
@@ -27,14 +27,16 @@
,"Picture"
(prog
(gui '(+Able +UpField) '(not (: home obj jpg)) 30)
- (gui '(+Button) '(if (: home obj jpg) ,"Uninstall" ,"Install")
- '(if (: home obj jpg)
- (ask ,"Uninstall Picture?"
- (put!> (: home top 1 obj) 'jpg NIL) )
- (let? F (val> (field -1))
- (blob! (: home obj) 'jpg (tmp F)) ) ) ) ) )
+ (gui '(+Drop +Button) '(field -1)
+ '(if (: home obj jpg) ,"Uninstall" ,"Install")
+ '(cond
+ ((: home obj jpg)
+ (ask ,"Uninstall Picture?"
+ (put!> (: home top 1 obj) 'jpg NIL) ) )
+ ((: drop) (blob! (: home obj) 'jpg @)) ) ) ) )
(<spread> NIL (editButton T))
- (when (: obj jpg)
- (<img> (allow (blob (: obj) 'jpg)) ,"Picture") ) ) ) )
+ (gui '(+Img)
+ '(and (: home obj jpg) (allow (blob (: home obj) 'jpg)))
+ ,"Picture") ) ) )
# vi:et:ts=3:sw=3
diff --git a/doc/refB.html b/doc/refB.html
@@ -103,6 +103,16 @@ overwritten. See also <code><a href="ref.html#cmp">Comparing</a></code> and
-> (1 2 3 4 5 6 7 8 9 10 20 30 40 50 60 70 80 90)
</code></pre>
+<dt><a name="basename"><code>(basename 'any) -> sym</code></a>
+<dd>Returns the filename part of a path name <code>any</code>. See also <code><a
+href="refD.html#dirname">dirname</a></code> and <code><a
+href="refP.html#path">path</a></code>.
+
+<pre><code>
+: (basename "a/b/c/d")
+-> "d"
+</code></pre>
+
<dt><a name="be"><code>(be sym . any) -> sym</code></a>
<dd>Declares a <a href="ref.html#pilog">Pilog</a> fact or rule for the
<code>sym</code> argument, by concatenating the <code>any</code> argument to the
diff --git a/doc/refD.html b/doc/refD.html
@@ -668,8 +668,9 @@ non-<code>NIL</code>. See also <code><a href="refC.html#cd">cd</a></code> and
</code></pre>
<dt><a name="dirname"><code>(dirname 'any) -> sym</code></a>
-<dd>Returns the directory part of a path name <code>any</code>.
-See also <code><a href="refP.html#path">path</a></code>.
+<dd>Returns the directory part of a path name <code>any</code>. See also
+<code><a href="refB.html#basename">basename</a></code> and <code><a
+href="refP.html#path">path</a></code>.
<pre><code>
: (dirname "a/b/c/d")
diff --git a/doc/refP.html b/doc/refP.html
@@ -176,7 +176,8 @@ argument with the <u>PicoLisp Home Directory</u>, as it was remembered during
interpreter startup. Optionally, the name may be preceded by a "<code>+</code>"
character (as used by <code><a href="refO.html#out">out</a></code>). This
mechanism is used internally by all I/O functions. See also <code><a
-href="ref.html#invoc">Invocation</a></code> and <code><a
+href="ref.html#invoc">Invocation</a></code>, <code><a
+href="refB.html#basename">basename</a></code>. and <code><a
href="refD.html#dirname">dirname</a></code>.
<pre><code>
diff --git a/lib/form.js b/lib/form.js
@@ -1,30 +1,15 @@
-/* 29jun10abu
+/* 09aug10abu
* (c) Software Lab. Alexander Burger
*/
var FormReq = false;
var HintReq = false;
-if (window.XMLHttpRequest) {
- try {
- FormReq = new XMLHttpRequest();
- HintReq = new XMLHttpRequest();
- }
- catch (e) {}
-}
-else if (window.ActiveXObject) { // IE
- try {
- FormReq = new ActiveXObject("Msxml2.XMLHTTP");
- HintReq = new ActiveXObject("Msxml2.XMLHTTP");
- }
- catch (e) {
- try {
- FormReq = new ActiveXObject("Microsoft.XMLHTTP");
- HintReq = new ActiveXObject("Microsoft.XMLHTTP");
- }
- catch (e) {}
- }
+try {
+ FormReq = new XMLHttpRequest();
+ HintReq = new XMLHttpRequest();
}
+catch (e) {}
var Queue = new Array();
var Btn = new Array();
@@ -39,7 +24,7 @@ function formKey(event) {
function fldChg(field) {
if (!InBtn && Key != 13)
- post(field.form);
+ post(field.form, null);
return true;
}
@@ -48,6 +33,17 @@ function doBtn(btn) {
return true;
}
+function doDrag(event) {
+ event.stopPropagation();
+ event.preventDefault();
+}
+
+function doDrop(btn, event) {
+ doDrag(event);
+ Btn.push(btn);
+ post(btn.form, event.dataTransfer.files[0]);
+}
+
/*** Form submit ***/
function doPost(form) {
for (var i = 0; ; ++i) {
@@ -56,10 +52,10 @@ function doPost(form) {
if (Btn[i].form == form)
break;
}
- return post(form);
+ return post(form, null);
}
-function post(form) {
+function post(form, file) {
var i, j, url, data;
if (!FormReq)
@@ -129,6 +125,8 @@ function post(form) {
fld.href = decodeURIComponent(txt[i++].substr(1));
}
}
+ else if (fld.tagName == "IMG")
+ fld.src = val;
else {
if (fld.type == "checkbox") {
fld.checked = val != "";
@@ -207,7 +205,7 @@ function post(form) {
}
form.style.cursor = "";
if (Queue.length > 0)
- post(Queue.shift());
+ post(Queue.shift(), null);
}
}
@@ -236,7 +234,16 @@ function post(form) {
data += "&" + fld.name + "=" + encodeURIComponent(val);
}
}
- try {FormReq.send(data);}
+ try {
+ if (!file)
+ FormReq.send(data);
+ else {
+ FormReq.setRequestHeader("X-Pil", "*ContLen=");
+ FormReq.sendAsBinary(data + "&*Drop=" +
+ encodeURIComponent(file.name) + "=" +
+ file.size + "\n" + file.getAsBinary() );
+ }
+ }
catch (e) {
FormReq.abort();
return true;
diff --git a/lib/form.l b/lib/form.l
@@ -1,4 +1,4 @@
-# 27jun10abu
+# 09aug10abu
# (c) Software Lab. Alexander Burger
# *PRG *Top *Gui *Btn *Get *Got *Form *Evt *Lock *Spans
@@ -6,7 +6,7 @@
(allow (path "@img/") T)
(push1 '*JS (allow (path "@lib/form.js")))
-(mapc allow '(*Gui *Get *Got *Form *Evt "@jsForm" "@jsHint"))
+(mapc allow '(*Gui *Get *Got *Form *Evt *Drop "@jsForm" "@jsHint"))
(one "*Cnt")
(off "*Lst" "*Post2" "*Cho")
@@ -102,8 +102,7 @@
This ) )
(htPrin "Prg") ) ) )
(--)
- (eval (: show))
- (=: show) ) ) )
+ (eval (: show)) ) ) )
# Disable form
(de disable (Flg)
@@ -996,6 +995,30 @@
(and (able) (eval (: act))) )
+(class +Drop)
+# "drop" drop
+
+(dm T (Fld . @)
+ (=: "drop" Fld)
+ (pass extra) )
+
+(dm show> ("Var")
+ (<style>
+ (quote
+ ("ondragenter" . "doDrag(event)")
+ ("ondragover" . "doDrag(event)")
+ ("ondrop" . "doDrop(this,event)") )
+ (extra "Var") ) )
+
+(dm act> ()
+ (=: drop
+ (and
+ (or *Drop (val> (eval (: "drop"))))
+ (tmp @) ) )
+ (off *Drop)
+ (extra) )
+
+
(class +JS)
(dm T @
@@ -1370,6 +1393,22 @@
,"Bad time format" ) )
+(class +Img +gui)
+# img alt url
+
+(dm T (Exe Alt)
+ (=: img Exe)
+ (=: alt Alt)
+ (super) )
+
+(dm js> ()
+ (ht:Fmt (sesId (or (eval (: img)) `(path "@img/no.png")))) )
+
+(dm show> ("Var")
+ (showFld
+ (<img> (or (eval (: img)) `(path "@img/no.png")) (eval (: alt))) ) )
+
+
(class +Icon)
# icon url
diff --git a/lib/http.l b/lib/http.l
@@ -1,4 +1,4 @@
-# 06jul10abu
+# 07aug10abu
# (c) Software Lab. Alexander Burger
# *Home *Gate *Host *Port *Port1 *Port% *Http1 *Chunked
@@ -154,7 +154,12 @@
((if *ContLen (ht:Read @) (line))
(for L (split @ '&)
(when (cdr (setq L (split L "=")))
- (_htSet (car L) (ht:Pack (cadr L))) ) ) )
+ (let? S (_htSet (car L) (ht:Pack (cadr L)))
+ (and
+ (cddr L)
+ (format (car @))
+ (unless (out (tmp S) (echo @))
+ (call 'rm "-f" (tmp S)) ) ) ) ) ) )
(T (throw "http")) ) )
(T
(out S
@@ -220,15 +225,13 @@
(and S (=0 *Http1) (task (close S))) ) )
(de _htHead ()
- (use (L @X @Y)
- (setq *Http1 (format (car @H)) *Chunked (gt0 *Http1))
+ (use (L @X @Y Pil)
+ (setq *Http1 (format (car @H)) *Chunked (gt0 *Http1) Pil)
(if (index "~" @U)
(setq *ConId (pack (head @ @U)) @U (cdr (nth @U @)))
(off *ConId) )
(while (setq L (line))
(cond
- ((match '(~(chop "Gate: ") @X " " . @Y) L)
- (setq *Gate (pack @X) *Adr (pack @Y)) )
((match '(~(chop "Host: ") . @X) L)
(setq *Host
(cond
@@ -251,7 +254,10 @@
((match '(~(chop "Content-@ype: multipart/form-data; boundary=") . @X) L)
(setq
*MPartLim (append '(- -) @X)
- *MPartEnd (append *MPartLim '(- -)) ) ) ) ) ) )
+ *MPartEnd (append *MPartLim '(- -)) ) )
+ ((match '(~(chop "X-Pil: ") @X "=" . @Y) L)
+ (push 'Pil (list 'setq (intern (pack @X)) (htArg @Y))) ) ) )
+ (run Pil) ) )
# rfc1867 multipart/form-data
(de _htMultipart ()
diff --git a/lib/misc.l b/lib/misc.l
@@ -1,4 +1,4 @@
-# 19jun10abu
+# 09aug10abu
# (c) Software Lab. Alexander Burger
# *Allow *Tmp
@@ -393,6 +393,9 @@
(de dirname (F)
(pack (flip (member '/ (flip (chop F))))) )
+(de basename (F)
+ (pack (stem (chop F) '/)) )
+
# Temporary Files
(de tmp @
(unless *Tmp
diff --git a/lib/tags b/lib/tags
@@ -120,7 +120,7 @@ eof (3351 . "@src64/io.l")
eol (3342 . "@src64/io.l")
errno (1358 . "@src64/main.l")
eval (208 . "@src64/flow.l")
-ext (4936 . "@src64/io.l")
+ext (4940 . "@src64/io.l")
ext? (1034 . "@src64/sym.l")
extern (900 . "@src64/sym.l")
extra (1284 . "@src64/flow.l")
@@ -135,7 +135,7 @@ find (1206 . "@src64/apply.l")
fish (1497 . "@src64/apply.l")
flg? (2419 . "@src64/subr.l")
flip (1686 . "@src64/subr.l")
-flush (4911 . "@src64/io.l")
+flush (4915 . "@src64/io.l")
fold (3345 . "@src64/sym.l")
for (2247 . "@src64/flow.l")
fork (3269 . "@src64/flow.l")
@@ -251,13 +251,13 @@ poll (3154 . "@src64/io.l")
pool (657 . "@src64/db.l")
pop (1773 . "@src64/sym.l")
port (5 . "@src64/net.l")
-pr (5027 . "@src64/io.l")
+pr (5031 . "@src64/io.l")
pre? (1411 . "@src64/sym.l")
-prin (4835 . "@src64/io.l")
-prinl (4849 . "@src64/io.l")
-print (4875 . "@src64/io.l")
-println (4906 . "@src64/io.l")
-printsp (4891 . "@src64/io.l")
+prin (4839 . "@src64/io.l")
+prinl (4853 . "@src64/io.l")
+print (4879 . "@src64/io.l")
+println (4910 . "@src64/io.l")
+printsp (4895 . "@src64/io.l")
prog (1779 . "@src64/flow.l")
prog1 (1787 . "@src64/flow.l")
prog2 (1804 . "@src64/flow.l")
@@ -276,15 +276,15 @@ rand (2959 . "@src64/big.l")
range (988 . "@src64/subr.l")
rank (2970 . "@src64/subr.l")
raw (465 . "@src64/main.l")
-rd (4953 . "@src64/io.l")
+rd (4957 . "@src64/io.l")
read (2530 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
rest (2271 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
-rewind (4919 . "@src64/io.l")
+rewind (4923 . "@src64/io.l")
rollback (1885 . "@src64/db.l")
rot (848 . "@src64/subr.l")
-rpc (5060 . "@src64/io.l")
+rpc (5064 . "@src64/io.l")
run (331 . "@src64/flow.l")
sect (2515 . "@src64/subr.l")
seed (2944 . "@src64/big.l")
@@ -298,7 +298,7 @@ size (2752 . "@src64/subr.l")
skip (3328 . "@src64/io.l")
sort (3869 . "@src64/subr.l")
sp? (711 . "@src64/sym.l")
-space (4853 . "@src64/io.l")
+space (4857 . "@src64/io.l")
split (1579 . "@src64/subr.l")
stack (571 . "@src64/main.l")
state (2028 . "@src64/flow.l")
@@ -341,7 +341,7 @@ when (1903 . "@src64/flow.l")
while (2080 . "@src64/flow.l")
wipe (3090 . "@src64/sym.l")
with (1349 . "@src64/flow.l")
-wr (5044 . "@src64/io.l")
+wr (5048 . "@src64/io.l")
xchg (1538 . "@src64/sym.l")
xor (1720 . "@src64/flow.l")
x| (2871 . "@src64/big.l")
diff --git a/src/httpGate.c b/src/httpGate.c
@@ -1,4 +1,4 @@
-/* 20jul09abu
+/* 07aug10abu
* (c) Software Lab. Alexander Burger
*/
@@ -172,7 +172,7 @@ int main(int ac, char *av[]) {
sd = gatePort(atoi(av[1])); // e.g. 80 or 443
ports[0] = atoi(av[2]); // e.g. 8080
if (ac == 3 || *av[3] == '\0')
- ssl = NULL, gate = "Gate: http %s\r\n";
+ ssl = NULL, gate = "X-Pil: *Gate=http\r\nX-Pil: *Adr=%s\r\n";
else {
SSL_library_init();
SSL_load_error_strings();
@@ -183,7 +183,7 @@ int main(int ac, char *av[]) {
ERR_print_errors_fp(stderr);
giveup("SSL init");
}
- ssl = SSL_new(ctx), gate = "Gate: https %s\r\n";
+ ssl = SSL_new(ctx), gate = "X-Pil: *Gate=https\r\nX-Pil: *Adr=%s\r\n";
}
for (n = 1; n < cnt; ++n)
ports[n] = atoi(av[n+3]);
diff --git a/src/io.c b/src/io.c
@@ -1,4 +1,4 @@
-/* 21jul10abu
+/* 07aug10abu
* (c) Software Lab. Alexander Burger
*/
@@ -2136,7 +2136,7 @@ any doEcho(any ex) {
if (om >= 0)
for (j = 0, n = op-p[i]; j <= n; ++j)
Env.put(av[om][j]);
- Env.get();
+ Chr = 0;
x = data(c[i]);
goto done;
}
@@ -2175,11 +2175,17 @@ any doEcho(any ex) {
if (Chr < 0)
return Nil;
}
- for (cnt = xCnt(ex,y); --cnt >= 0; Env.get()) {
- if (Chr < 0)
- return Nil;
- Env.put(Chr);
+ if ((cnt = xCnt(ex,y)) > 0) {
+ for (;;) {
+ if (Chr < 0)
+ return Nil;
+ Env.put(Chr);
+ if (!--cnt)
+ break;
+ Env.get();
+ }
}
+ Chr = 0;
return T;
}
diff --git a/src64/io.l b/src64/io.l
@@ -1,4 +1,4 @@
-# 21jul10abu
+# 07aug10abu
# (c) Software Lab. Alexander Burger
# Close file descriptor
@@ -4259,19 +4259,23 @@
call (Get_A) # Get next
loop
end
- do
- sub E 1 # Decrement second 'cnt'
- while ns
- null A # EOF?
- if s # Yes
- ld E Nil # Return NIL
- pop Y
- pop X
- ret
- end
- call (PutB) # Output byte
- call (Get_A) # Get next
- loop
+ null E # 'cnt'?
+ if nsz # Yes
+ do
+ null A # EOF?
+ if s # Yes
+ ld E Nil # Return NIL
+ pop Y
+ pop X
+ ret
+ end
+ call (PutB) # Output byte
+ sub E 1 # Decrement 'cnt'
+ while nz
+ call (Get_A) # Get next
+ loop
+ end
+ ld (Chr) 0 # Clear look ahead
ld E TSym # Return T
pop Y
pop X
@@ -4334,7 +4338,7 @@
sub E 1
loop
end
- call (Get_A) # Skip next input byte
+ ld (Chr) 0 # Clear look ahead
ld E (Z II) # Return matched symbol
jmp 90
end
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 05aug10abu
+# 09aug10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 3 11)
+(de *Version 3 0 3 12)
# vi:et:ts=3:sw=3
diff --git a/test/lib/misc.l b/test/lib/misc.l
@@ -1,4 +1,4 @@
-# 18jun10abu
+# 09aug10abu
# (c) Software Lab. Alexander Burger
### locale ###
@@ -204,8 +204,9 @@
(test P (pwd)) )
-### dirname ###
+### dirname basename ###
(test "a/b/c/" (dirname "a/b/c/d"))
+(test "d" (basename "a/b/c/d"))
### fmt64 ###
diff --git a/test/src/io.l b/test/src/io.l
@@ -1,4 +1,4 @@
-# 22mar10abu
+# 07aug10abu
# (c) Software Lab. Alexander Burger
### path ###
@@ -145,6 +145,13 @@
(test 123 (read))
(test 'abc (read))
(test '(d e f) (read)) )
+(let F (tmp "file")
+ (test "12"
+ (pipe (in F (echo 2))
+ (line T) ) )
+ (test "23"
+ (pipe (in F (echo 1 2))
+ (line T) ) ) )
### prin prinl space print printsp println ###
