#!/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}){
$INTERNAL{q} = "\17"; #^Q
$header{'content-type'} = 'text/html';
-$header{'status'} = '200 OK';
+$header{status} = '200 OK';
$INTERNAL{code} = ReadFile($INTERNAL{file});
while ($INTERNAL{code} =~ s/<_(.*?)_>//s){
$INTERNAL{pre} = $1;
- eval $INTERNAL{pre};
+ {
+ no strict;
+ eval $INTERNAL{pre};
+ if ($@ && $DEBUG){
+ print "\nDebug:\n $@";
+ }
+ }
}
for (keys %header){
}
print "\n";
-eval $INTERNAL{code};
-if ($@){
- print "<hr><b>Debug</b><br>", Entity($@);
-}
-
-if ($Debug){
- print "<hr>Debug:<pre>$INTERNAL{code}<hr>$output";
+{
+ no strict;
+ eval $INTERNAL{code};
+ if ($@ && $DEBUG){
+ print "<hr><b>Debug</b><br>", Entity($@);
+ }
}
+#!/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];
}
}
$INTERNAL{post} = <STDIN>;
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];
}
}
+#!/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 "<!-- $INTERNAL{hash}: $INTERNAL{human} -->";
- for (keys %{$INTERNAL{hash}}){
- print qq{<input type=hidden name="$_" value="${$INTERNAL{hash}}{$_}">}
- unless $INTERNAL{saves} =~ /$INTERNAL{q}$_$INTERNAL{q}/;
+ my $hash = shift;
+ my %saves;
+ $saves{@_} = ();
+ for (keys %$hash){
+ print qq{<input type=hidden name="$_" value="$hash->{$_}">}
+ unless exists $saves{$_};
}
}
-sub NoHeaders($){
- $_[0] =~ s/^.*?\n\n//;
- return $_[0]
-}
-
-sub Entity($;$$$$){
- $_[4] ||= 4;
- $_[0] =~ s/&/&/g;
- $_[0] =~ s/\"/"/g;
- $_[0] =~ s/</</g;
- $_[0] =~ s/>/>/g;
- if ($_[1]){
- $_[0] =~ s/\n/<br>\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/>/>/g;
+ s/\n/<br>\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($){
print WRITEFILE $_[1];
close WRITEFILE;
}
+
+sub Counter($){
+ my $o = $/; undef $/;
+ open COUNTER, "+<$_[0]";
+ flock COUNTER, 2;
+ seek COUNTER, 0, 0;
+ my $counter = <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</g;
+ # Now this is a big, ugly regex! But hey - it works :)
+ $$ref =~ s{((\w+://|www\.|WWW\.)[a-zA-Z0-9\.\@:-]+[^\"\'>< \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{<a href="$c" target="_blank">$_</a>$b}
+ }eg;
+
+
+ $$ref =~ s/"\cC"/"/g;
+ $$ref =~ s/>\cC>/>/g;
+ $$ref =~ s/<\cC</</g;
+ };
+ if ($@){ return defined wantarray ? @_ : undef }
+ return defined wantarray ? $$ref : undef;
+}
1;
\ No newline at end of file