v2.01 release

diff --git a/plp.cgi b/plp.cgi
new file mode 100755 (executable)
index 0000000..c281fc0
--- /dev/null
+++ b/plp.cgi
@@ -0,0 +1,74 @@
+#!/usr/bin/perl
+
+$VERSION = '2.01';
+
+$INTERNAL{file} = $ENV{PATH_TRANSLATED};
+unless (-e $INTERNAL{file}){
+    $ENV{REDIRECT_STATUS} = '404';
+    print STDERR "htmpl: Not found: $INTERNAL{file}\n";
+
+    #Change this if you have an error handling script.
+    print `/vhost/COMMON/err.cgi` || "Status: 404 Not found\n\nFile not found";
+    
+    exit;
+}
+
+($INTERNAL{dir} = $INTERNAL{file}) =~ s{^(.*)/.*?$}[$1];
+chdir $INTERNAL{dir};
+
+($ENV{PLP_NAME} = $ENV{REQUEST_URI}) =~ s/\?.*$//;
+
+use plp;
+
+$INTERNAL{qq} = "\10"; #^P
+$INTERNAL{q}  = "\17"; #^Q
+
+$header{'content-type'} = 'text/html';
+$header{'status'} = '200 OK';
+
+$INTERNAL{code} = ReadFile($INTERNAL{file});
+
+while ($INTERNAL{code} =~ /<\((.*?)\)>/ ){
+    ($INTERNAL{file} = $1) =~ s/[<>\|]//g;
+    $INTERNAL{code} =~ s//ReadFile($INTERNAL{file})/e;
+}
+
+$INTERNAL{code} =~ s(<:)($INTERNAL{q};)g;
+$INTERNAL{code} =~ s(:>)(;\nprint q$INTERNAL{q})g;
+
+while ($INTERNAL{code} =~ /(<\[1(.*?)\]>(.*?)<\[2\]>(.*?)<\[3\]>)/s){
+    $INTERNAL{naam} = $2;
+    $BLOCK{"$INTERNAL{naam}-1"} = $3;
+    $BLOCK{"$INTERNAL{naam}-2"} = $4;
+    $INTERNAL{code} =~ s///;  #Redo last match
+}
+$INTERNAL{code} =~ s(\\\\\r?\n)()g;
+$INTERNAL{code} =~ s(<\[([^>]*?):(.*?)\]>)($BLOCK{"${1}-1"}$2$BLOCK{"${1}-2"})g;
+$INTERNAL{code} =~ s(<\[(?!/)(.*?)\]>)($BLOCK{"${1}-1"})g;
+$INTERNAL{code} =~ s(<\[/(.*?)\]>)($BLOCK{"${1}-2"})g;
+$INTERNAL{code} =~ s(<{[ \08\09]*)($INTERNAL{q};print qq$INTERNAL{qq})g;
+$INTERNAL{code} =~ s([ \08\09]*}>)($INTERNAL{qq};print q$INTERNAL{q})g;
+$INTERNAL{code} = "print q$INTERNAL{q}$INTERNAL{code}$INTERNAL{q};";
+
+$INTERNAL{code} =~ s{print qq$INTERNAL{qq}$INTERNAL{qq};}[]g;
+$INTERNAL{code} =~ s{print q$INTERNAL{q}$INTERNAL{q};}[]g;
+
+
+while ($INTERNAL{code} =~ s/<_(.*?)_>//s){
+    $INTERNAL{pre} = $1;    
+    eval $INTERNAL{pre};
+}
+
+for (keys %header){
+    print "$_: $header{$_}\n";
+}
+print "\n";
+
+eval $INTERNAL{code};
+if ($@){
+    print "<hr><b>Debug</b><br>", Entity($@);
+}
+
+if ($Debug){
+    print "<hr>Debug:<pre>$INTERNAL{code}<hr>$output";
+}

diff --git a/plp.pm b/plp.pm
new file mode 100644 (file)
index 0000000..2d6f512
--- /dev/null
+++ b/plp.pm
@@ -0,0 +1,3 @@
+use plpfunc;
+use plpfields;
+1;
\ No newline at end of file

diff --git a/plpfields.pm b/plpfields.pm
new file mode 100644 (file)
index 0000000..2babb6e
--- /dev/null
+++ b/plpfields.pm
@@ -0,0 +1,35 @@
+if ($ENV{QUERY_STRING} ne ''){
+    for (split /&/, $ENV{QUERY_STRING}) {
+       split /=/;
+       for (@_) {
+           $_ = DecodeURI($_);
+       }
+       $get{$_[0]} = $_[1];
+    }
+}
+
+
+$INTERNAL{post} = <STDIN>;
+if ($INTERNAL{post} ne ''){
+    for (split /&/, $INTERNAL{post}) {
+       split /=/;
+       for (@_) {
+           $_ = DecodeURI($_);
+       }
+       $post{$_[0]} = $_[1];
+    }
+}
+%fields=(%get, %post);
+
+$INTERNAL{koek} = $ENV{HTTP_COOKIE};
+if ($INTERNAL{koek} ne ''){
+    for (split /; ?/, $INTERNAL{koek}) {
+       split /=/;
+       #for (@_) {
+       #    $_ = DecodeURI($_);
+       #}
+       $cookie{$_[0]} ||= $_[1];
+    }
+}
+
+1;

diff --git a/plpfunc.pm b/plpfunc.pm
new file mode 100644 (file)
index 0000000..ae3dd4f
--- /dev/null
+++ b/plpfunc.pm
@@ -0,0 +1,74 @@
+sub HiddenFields($@){
+    $INTERNAL{hash} = shift;
+    $INTERNAL{saves} = $INTERNAL{q} . (join $INTERNAL{q}, @_) . $INTERNAL{q};
+#    $INTERNAL{human} = join ',', @_;
+#    print "<!-- $INTERNAL{hash}: $INTERNAL{human} -->";
+    for (keys %{$INTERNAL{hash}}){
+       print qq{<input type=hidden name="$_" value="${$INTERNAL{hash}}{$_}">}
+           unless $INTERNAL{saves} =~ /$INTERNAL{q}$_$INTERNAL{q}/;
+    }
+}
+
+sub NoHeaders($){
+    $_[0] =~ s/^.*?\n\n//;
+    return $_[0]
+}
+
+sub Entity($;$$$$){
+    $_[4] ||= 4;
+    $_[0] =~ s/&/&amp;/g;
+    $_[0] =~ s/\"/&quot;/g;
+    $_[0] =~ s/</&lt;/g;
+    $_[0] =~ s/>/&gt;/g;
+    if ($_[1]){
+       $_[0] =~ s/\n/<br>\n/g;
+    }
+    if ($_[2]){
+       $_[0] =~ s/\t/' ' x $_[4]/eg;
+    }
+    if ($_[3]){
+       $_[0] =~ s/  /&nbsp;&nbsp;/g;
+    }
+    return $_[0]
+}
+
+sub DecodeURI($;$){
+    my $t = $_[0];
+    $t =~ tr{+} { } unless ($_[1] == 1);
+    $t =~ s{%([0-9A-Fa-f]{2})}
+          {pack('c',hex($1))}ge;
+    return $t;
+}
+
+sub EncodeURI($;$){
+    my $t = $_[0];
+    $t =~ s{([^a-zA-Z0-9_\-.])}
+           {uc sprintf("%%%02x",ord($1))}ge;
+    $t =~ s{%20}{+}g if ($_[1] == 1);
+    return $t;
+}
+
+sub AddCookie($){
+    if ($header{'set-cookie'}){
+       $header{'set-cookie'} .= "\nset-cookie: $_[0]";
+    }else{
+       $header{'set-cookie'} = $_[0];
+    }
+}
+
+sub ReadFile($){
+    my $o = $/; undef $/;    
+    open (READFILE, $_[0]);
+    my $r = <READFILE>;
+    close READFILE;
+    $/ = $o;
+    return $r;
+}
+
+sub WriteFile($$){
+    open (WRITEFILE, ">$_[0]");
+    flock WRITEFILE, 2;
+    print WRITEFILE $_[1];
+    close WRITEFILE;
+}
+1;
\ No newline at end of file