X-Git-Url: http://git.shiar.net/perl/plp/.git/blobdiff_plain/7509565253b19493771cfc2e13ab166f1a8cc5f8..0dee415b1a371573e705c18f09e70c555845e428:/PLP/Functions.pm
diff --git a/PLP/Functions.pm b/PLP/Functions.pm
index 61d145d..3eb07ca 100644
--- a/PLP/Functions.pm
+++ b/PLP/Functions.pm
@@ -1,192 +1,151 @@
-#-------------------------#
- package PLP::Functions;
-#-------------------------#
+package PLP::Functions;
+
use base 'Exporter';
use Fcntl qw(:flock);
use strict;
-our @EXPORT = qw/HiddenFields Entity DecodeURI EncodeURI Entity include PLP_END
- AddCookie ReadFile WriteFile AutoURL Counter Include exit/;
+our @EXPORT = qw/Entity DecodeURI EncodeURI Include include PLP_END
+ AddCookie ReadFile WriteFile AutoURL Counter exit/;
sub Include ($) {
- no strict;
- $PLP::file = $_[0];
- $PLP::inA = 0;
- $PLP::inB = 0;
- local $@;
- eval 'package PLP::Script; ' . PLP::source($PLP::file, 0, join ' ', (caller)[2,1]);
- if ($@) {
- PLP::Functions::exit if $@ =~ /\cS\cT\cO\cP/;
- PLP::error($@, 1);
- }
+ no strict;
+ $PLP::file = $_[0];
+ $PLP::inA = 0;
+ $PLP::inB = 0;
+ local $@;
+ eval 'package PLP::Script; ' . PLP::source($PLP::file, 0, join ' ', (caller)[2,1]);
+ if ($@) {
+ PLP::Functions::exit() if $@ =~ /\cS\cT\cO\cP/;
+ PLP::error($@, 1);
+ }
}
sub include ($) {
- goto &Include;
+ goto &Include;
}
sub exit (;$) {
- die "\cS\cT\cO\cP\n";
+ die "\cS\cT\cO\cP\n";
}
sub PLP_END (&) {
- push @PLP::END, shift;
-}
-
-sub HiddenFields ($@) {
- my $hash = shift;
- my %saves;
- @saves{@_} = ();
- for (keys %$hash) {
- print qq{}
- unless exists $saves{$_};
- }
+ push @PLP::END, shift;
}
sub Entity (@) {
- my $ref;
- my @copy;
- if (defined wantarray) {
- @copy = @_;
- $ref = \@copy;
- } else {
- $ref = \@_;
- }
- for (@$ref) {
- eval {
- s/&/&/g;
- s/\"/"/g;
- s/</g;
- s/>/>/g;
- s/\n/ \n/g;
- s/\t/ /g;
- s/ / /g;
- };
-# if ($@){ return defined wantarray ? @_ : undef }
- }
- return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
+ my $ref = defined wantarray ? [@_] : \@_;
+ for (@$ref) {
+ eval {
+ s/&/&/g;
+ s/"/"/g;
+ s/</g;
+ s/>/>/g;
+ s/\n/ \n/g;
+ s/\t/ /g;
+ s/ / /g;
+ };
+ }
+ return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
}
-# Browsers do s/ /+/ - I don't care about RFC's, but I do care about real-life
-# situations.
sub DecodeURI (@) {
- my @r;
- local $_;
- for (@_) {
- s/\+/%20/g;
- my $dec = $_;
- $dec =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
- if (defined wantarray) {
- push @r, $dec;
- } else {
- eval {$_ = $dec};
-# return undef if $@; # ;DecodeURI("foo");
+ my $ref = defined wantarray ? [@_] : \@_;
+ for (@$ref) {
+ eval {
+ tr/+/ /; # Browsers do tr/ /+/ - I don't care about RFCs, but
+ # I do care about real-life situations.
+ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
+ };
}
- }
- return defined wantarray ? (wantarray ? @r : "@r") : undef;
+ return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
}
+
sub EncodeURI (@) {
- my @r;
- local $_;
- for (@_) {
- my $esc = $_;
- $esc =~
- s{
- ([^\/?:@\$,A-Za-z0-9\-_.!~*\'()])
- }{
- sprintf("%%%02x", ord($1))
- }xge;
- if (defined wantarray) {
- push @r, $esc;
- } else {
- eval {$_ = $esc};
-# return undef if $@; # ;EncodeURI("foo");
+ my $ref = defined wantarray ? [@_] : \@_;
+ for (@$ref) {
+ eval {
+ s{([^A-Za-z0-9\-_.!~*'()/?:@\$,])}{sprintf("%%%02x", ord $1)}ge;
+ };
}
- }
- return defined wantarray ? (wantarray ? @r : "@r") : undef;
+ return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
}
sub AddCookie ($) {
- if ($PLP::Script::header{'Set-Cookie'}) {
- $PLP::Script::header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]";
- } else {
- $PLP::Script::header{'Set-Cookie'} = $_[0];
- }
+ if ($PLP::Script::header{'Set-Cookie'}) {
+ $PLP::Script::header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]";
+ } else {
+ $PLP::Script::header{'Set-Cookie'} = $_[0];
+ }
}
sub ReadFile ($) {
- local $/ = undef;
- open (my $fh, '<', $_[0]) or do {
- PLP::error("Cannot open $_[0] for reading ($!)", 1);
- return undef;
- };
- my $r = readline $fh;
- close $fh;
- return $r;
+ local $/ = undef;
+ open (my $fh, '<', $_[0]) or do {
+ PLP::error("Cannot open $_[0] for reading ($!)", 1);
+ return undef;
+ };
+ my $r = readline $fh;
+ close $fh;
+ return $r;
}
sub WriteFile ($$) {
- open (my $fh, '>', $_[0]) or do {
- PLP::error("Cannot open $_[0] for writing ($!)", 1);
- return undef;
- };
- flock $fh, LOCK_EX;
- print $fh $_[1] or do {
- PLP::error("Cannot write to $_[0] ($!)");
- return undef;
- };
- close $fh or do {
- PLP::error("Cannot close $_[0] ($!)");
- return undef;
- };
- return 1;
+ open (my $fh, '>', $_[0]) or do {
+ PLP::error("Cannot open $_[0] for writing ($!)", 1);
+ return undef;
+ };
+ flock $fh, LOCK_EX;
+ print $fh $_[1] or do {
+ PLP::error("Cannot write to $_[0] ($!)");
+ return undef;
+ };
+ close $fh or do {
+ PLP::error("Cannot close $_[0] ($!)");
+ return undef;
+ };
+ return 1;
}
sub Counter ($) {
- local $/ = undef;
- my $fh;
- open $fh, '+<', $_[0] or
- open $fh, '>', $_[0] or return undef;
- flock $fh, 2;
- seek $fh, 0, 0;
- my $counter = <$fh>;
- seek $fh, 0, 0;
- truncate $fh, 0;
- print $fh ++$counter or return undef;
- close $fh or return undef;
- return $counter;
+ local $/ = undef;
+ my $fh;
+ open $fh, '+<', $_[0] or
+ open $fh, '>', $_[0] or return undef;
+ flock $fh, 2;
+ seek $fh, 0, 0;
+ my $counter = <$fh>;
+ seek $fh, 0, 0;
+ truncate $fh, 0;
+ print $fh ++$counter or return undef;
+ close $fh or return undef;
+ return $counter;
}
sub AutoURL ($) {
- # This sub assumes your string does not match /(["<>])\cC\1/
- my $ref;
- if (defined wantarray){
- $ref = \(my $copy = $_[0]);
- }else{
- $ref = \$_[0];
- }
- eval {
- $$ref =~ s/"/"\cC"/g; # Single characters are easier to match :)
- $$ref =~ s/>/>\cC>/g; # so we can just use a character class []
- $$ref =~ s/</<\cC< \r\t\n]*)}{
- local $_ = $1;
- my $scheme = $2;
- s/// if (my $trailing) = /([\.,!\?\(\)\[\]]+$)/;
- s/&(?!\x23?\w+;)/&/g;
- s/\"/"/g;
- my $href = ($scheme =~ /www\./i ? "http://$_" : $_);
- qq{$_$trailing};
- }eg;
-
- $$ref =~ s/"\cC"/"/g;
- $$ref =~ s/>\cC>/>/g;
- $$ref =~ s/<\cC</g;
- };
- if ($@){ return defined wantarray ? @_ : undef }
- return defined wantarray ? $$ref : undef;
+ # This sub assumes your string does not match /(["<>])\cC\1/
+ my $ref = defined wantarray ? \(my $copy = $_[0]) : \$_[0];
+ eval {
+ $$ref =~ s/"/"\cC"/g; # Single characters are easier to match :)
+ $$ref =~ s/>/>\cC>/g; # so we can just use a character class []
+ $$ref =~ s/</<\cC< \r\t\n]*)}{
+ local $_ = $1;
+ my $scheme = $2;
+ s/// if (my $trailing) = /([\.,!\?\(\)\[\]]+$)/;
+ s/&(?!\x23?\w+;)/&/g;
+ s/\"/"/g;
+ my $href = ($scheme =~ /www\./i ? "http://$_" : $_);
+ qq{$_$trailing};
+ }eg;
+
+ $$ref =~ s/"\cC"/"/g;
+ $$ref =~ s/>\cC>/>/g;
+ $$ref =~ s/<\cC</g;
+ };
+ if ($@){ return defined wantarray ? @_ : undef } # return original on error
+ return defined wantarray ? $$ref : undef;
}
1;
@@ -217,6 +176,16 @@ Some context examples:
Executes another PLP file, that will be parsed (i.e. code must be in C<< <: :> >>). As with Perl's C, the file is evaluated in its own lexical file scope, so lexical variables (C variables) are not shared. PLP's C<< <(filename)> >> includes at compile-time, is faster and is doesn't create a lexical scope (it shares lexical variables).
+Include can be used recursively, and there is no depth limit:
+
+
+ <:
+ include 'crash.plp';
+ # This example will loop forever,
+ # and dies with an out of memory error.
+ # Do not try this at home.
+ :>
+
=item include FILENAME
An alias for C.
@@ -237,23 +206,32 @@ You should use this function instead of Perl's built-in C blocks, because t
=item Entity LIST
-Replaces HTML syntax characters by HTML entities, so they can be displayed literally. You should always use this on user input (or database output), to avoid cross-site-scripting vurnerabilities. This function does not do everything the L does.
+Replaces HTML syntax characters by HTML entities, so they can be displayed literally. You should always use this when displaying user input (or database output), to avoid cross-site-scripting vurnerabilities.
In void context, B the values of the given variables. In other contexts, returns the changed versions.
<: print Entity($user_input); :>
+Be warned that this function also HTMLizes consecutive whitespace and newlines (using and respectively).
+For simple escaping, use L. To escape high-bit characters as well, use L.
+
=item EncodeURI LIST
-Replaces characters by their %-encoded values.
+Encodes URI strings according to RFC 3986. All disallowed characters are replaced by their %-encoded values.
In void context, B the values of the given variables. In other contexts, returns the changed versions.
Link
+Note that the following reserved characters are I percent-encoded, even though they may have a special meaning in URIs:
+
+ / ? : @ $
+
+This should be safe for escaping query values (as in the example above), but it may be a better idea to use L instead.
+
=item DecodeURI LIST
-Decodes %-encoded strings.
+Decodes %-encoded strings. Unlike L, it also translates + characters to spaces (as browsers use those).
In void context, B the values of the given variables. In other contexts, returns the changed versions.
@@ -287,7 +265,9 @@ Adds a Set-Cookie header. STRING must be a valid Set-Cookie header value.
=head1 AUTHOR
-Juerd Waalboer
+Juerd Waalboer
+
+Current maintainer: Mischa POSLAWSKY
=cut