From b5eadb0c810558015cd4dc943e2c25b4acbfec58 Mon Sep 17 00:00:00 2001 From: Juerd Waalboer Date: Tue, 1 May 2001 08:00:24 +0000 Subject: [PATCH] v2.21 release --- plp.cgi | 28 ++++++---- plpfields.pm | 38 +++++++------- plpfunc.pm | 142 +++++++++++++++++++++++++++++++++++++-------------- 3 files changed, 140 insertions(+), 68 deletions(-) diff --git a/plp.cgi b/plp.cgi index c281fc0..3bf77f9 100755 --- a/plp.cgi +++ b/plp.cgi @@ -1,6 +1,9 @@ #!/usr/bin/perl +use strict; +use vars qw($VERSION %INTERNAL %get %post %fields %header %cookie %BLOCK $DEBUG $output); -$VERSION = '2.01'; +$VERSION = '2.21'; +$DEBUG = 1; $INTERNAL{file} = $ENV{PATH_TRANSLATED}; unless (-e $INTERNAL{file}){ @@ -24,7 +27,7 @@ $INTERNAL{qq} = ""; #^P $INTERNAL{q} = ""; #^Q $header{'content-type'} = 'text/html'; -$header{'status'} = '200 OK'; +$header{status} = '200 OK'; $INTERNAL{code} = ReadFile($INTERNAL{file}); @@ -56,7 +59,13 @@ $INTERNAL{code} =~ s{print q$INTERNAL{q}$INTERNAL{q};}[]g; while ($INTERNAL{code} =~ s/<_(.*?)_>//s){ $INTERNAL{pre} = $1; - eval $INTERNAL{pre}; + { + no strict; + eval $INTERNAL{pre}; + if ($@ && $DEBUG){ + print "\nDebug:\n $@"; + } + } } for (keys %header){ @@ -64,11 +73,10 @@ for (keys %header){ } print "\n"; -eval $INTERNAL{code}; -if ($@){ - print "
Debug
", Entity($@); -} - -if ($Debug){ - print "
Debug:
$INTERNAL{code}
$output";
+{
+    no strict;
+    eval $INTERNAL{code};
+    if ($@ && $DEBUG){
+	print "
Debug
", Entity($@);
+    }
 }
diff --git a/plpfields.pm b/plpfields.pm
index 2babb6e..8f566a2 100644
--- a/plpfields.pm
+++ b/plpfields.pm
@@ -1,10 +1,13 @@
+#!/usr/bin/perl
+# shebang only for color coding, just ignore it m'kay?
+use strict;
+use vars qw(%get %post %fields %cookie %INTERNAL);
+
 if ($ENV{QUERY_STRING} ne ''){
     for (split /&/, $ENV{QUERY_STRING}) {
-	split /=/;
-	for (@_) {
-	    $_ = DecodeURI($_);
-	}
-	$get{$_[0]} = $_[1];
+	my @keyval = split /=/;
+	DecodeURI(@keyval);
+	$get{$keyval[0]} = $keyval[1];
     }
 }
 
@@ -12,23 +15,20 @@ if ($ENV{QUERY_STRING} ne ''){
 $INTERNAL{post} = ;
 if ($INTERNAL{post} ne ''){
     for (split /&/, $INTERNAL{post}) {
-	split /=/;
-	for (@_) {
-	    $_ = DecodeURI($_);
-	}
-	$post{$_[0]} = $_[1];
+	my @keyval = split /=/;
+	DecodeURI(@keyval);
+	$post{$keyval[0]} = $keyval[1];
     }
 }
-%fields=(%get, %post);
 
-$INTERNAL{koek} = $ENV{HTTP_COOKIE};
-if ($INTERNAL{koek} ne ''){
-    for (split /; ?/, $INTERNAL{koek}) {
-	split /=/;
-	#for (@_) {
-	#    $_ = DecodeURI($_);
-	#}
-	$cookie{$_[0]} ||= $_[1];
+%fields = %get;
+@fields{keys %post} = values %post;
+#%fields = (%get, %post);
+
+if ($ENV{HTTP_COOKIE} ne ''){
+    for (split /; ?/, $ENV{HTTP_COOKIE}) {
+	my @keyval = split /=/;
+	$cookie{$keyval[0]} ||= $keyval[1];
     }
 }
 
diff --git a/plpfunc.pm b/plpfunc.pm
index ae3dd4f..49bb63c 100644
--- a/plpfunc.pm
+++ b/plpfunc.pm
@@ -1,51 +1,72 @@
+#!/usr/bin/perl
+# The shebang is only there for mcedit syntax highlights, as I'm too lazy to 
+# change the configfile. It won't hurt performance
+use URI::Escape;
+use strict;
+use vars qw(%header);
+
 sub HiddenFields($@){
-    $INTERNAL{hash} = shift;
-    $INTERNAL{saves} = $INTERNAL{q} . (join $INTERNAL{q}, @_) . $INTERNAL{q};
-#    $INTERNAL{human} = join ',', @_;
-#    print "";
-    for (keys %{$INTERNAL{hash}}){
-	print qq{}
-	    unless $INTERNAL{saves} =~ /$INTERNAL{q}$_$INTERNAL{q}/;
+    my $hash = shift;
+    my %saves;
+    $saves{@_} = ();
+    for (keys %$hash){
+	print qq{}
+	    unless exists $saves{$_};
     }
 }
 
-sub NoHeaders($){
-    $_[0] =~ s/^.*?\n\n//;
-    return $_[0]
-}
-
-sub Entity($;$$$$){
-    $_[4] ||= 4;
-    $_[0] =~ s/&/&/g;
-    $_[0] =~ s/\"/"/g;
-    $_[0] =~ s//>/g;
-    if ($_[1]){
-	$_[0] =~ s/\n/
\n/g;
-    }
-    if ($_[2]){
-	$_[0] =~ s/\t/' ' x $_[4]/eg;
+sub Entity(@){
+    my $ref;
+    my @copy;    
+    if (defined wantarray){
+	@copy = @_;
+	$ref = \@copy;
+    }else{
+	$ref = \@_;
     }
-    if ($_[3]){
-	$_[0] =~ s/  /  /g;
+    for (@$ref){
+	eval {
+	    s/&/&/g;
+	    s/\"/"/g;
+	    s//>/g;
+	    s/\n/
\n/g;
+	    s/\t/    /eg;
+	    s/  /  /g;
+	};
+	if ($@){ return defined wantarray ? @_ : undef }
     }
-    return $_[0]
+    return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
 }
 
-sub DecodeURI($;$){
-    my $t = $_[0];
-    $t =~ tr{+} { } unless ($_[1] == 1);
-    $t =~ s{%([0-9A-Fa-f]{2})}
-	   {pack('c',hex($1))}ge;
-    return $t;
+# Browsers do s/ /+/ - I don't care about RFC's, but I do care about real-life
+# situations.
+sub DecodeURI(@){
+    my @r;    
+    for (@_){
+	s/\+/%20/g;
+	my $dec = uri_unescape($_);
+	if (defined wantarray){
+	    push @r, $dec;
+	}else{
+	    eval {$_ = $dec}; 
+	    return undef if $@; # ;DecodeURI("foo");
+	}
+    }
+    return defined wantarray ? (wantarray ? @r : "@r") : undef;
 }
-
-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 EncodeURI(@){
+    my @r;
+    for (@_){
+        my $esc = uri_escape($_, '^;\/?:@&=\$,A-Za-z0-9\-_.!~*\'()');
+        if (defined wantarray){
+            push @r, $esc;
+        }else{
+	    eval {$_ = $esc};
+	    return undef if $@; # ;EncodeURI("foo");
+	}
+    }
+    return defined wantarray ? (wantarray ? @r : "@r") : undef;
 }
 
 sub AddCookie($){
@@ -71,4 +92,47 @@ sub WriteFile($$){
     print WRITEFILE $_[1];
     close WRITEFILE;
 }
+
+sub Counter($){
+    my $o = $/; undef $/;
+    open           COUNTER, "+<$_[0]";
+    flock          COUNTER, 2;
+    seek           COUNTER, 0, 0;
+    my $counter = ;
+    seek           COUNTER, 0, 0;
+    truncate       COUNTER, 0;
+    print          COUNTER ++$counter;
+    close          COUNTER;
+    $/ = $o;
+    return $counter;
+}
+
+sub AutoURL($){
+    my $ref;    
+    if (defined wantarray){
+	$ref = \(my $copy = $_[0]);
+    }else{
+	$ref = \$_[0];
+    }
+    eval {
+	my ($p, $b, $c);
+	$$ref =~ s/"/"\cC"/g;
+	$$ref =~ s/>/>\cC>/g;
+	$$ref =~ s/</<\cC< \r\t\n]*)}{
+	    local $_ = $1, $p = $2, ((($b) = /([\.,!\?\(\)\[\]]+$)/) ? s/// :
+	    undef), s/&(?!\x23?\w+;)/&/g, s/\"/"/g, $c = 
+	    ($p eq 'www.' || $p eq 'WWW.' ? "http://$_" : $_),
+	    qq{$_$b}
+	}eg;
+
+
+	$$ref =~ s/"\cC"/"/g;
+	$$ref =~ s/>\cC>/>/g;
+	$$ref =~ s/<\cC