PLP/Functions.pm

   1 #-------------------------#
   2   package PLP::Functions;
   3 #-------------------------#
   4 use base 'Exporter';
   5 use Fcntl qw(:flock);
   6 use strict;
   7
   8 our @EXPORT = qw/HiddenFields Entity DecodeURI EncodeURI Entity include PLP_END
   9                  AddCookie ReadFile WriteFile AutoURL Counter Include exit/;
  10
  11 sub Include ($) {
  12     no strict;
  13     $PLP::file = $_[0];
  14     $PLP::inA = 0;
  15     $PLP::inB = 0;
  16     local $@;
  17     eval 'package PLP::Script; ' . PLP::source($PLP::file, 0, join ' ', (caller)[2,1]);
  18     if ($@) {
  19         PLP::Functions::exit if $@ =~ /\cS\cT\cO\cP/;
  20         PLP::error($@, 1);
  21     }
  22 }
  23
  24 sub include ($) {
  25     goto &Include;
  26 }
  27
  28 sub exit (;$) {
  29     die "\cS\cT\cO\cP\n";
  30 }
  31
  32 sub PLP_END (&) {
  33     push @PLP::END, shift;
  34 }
  35
  36 sub HiddenFields ($@) {
  37     my $hash = shift;
  38     my %saves;
  39     @saves{@_} = ();
  40     for (keys %$hash) {
  41         print qq{<input type=hidden name="$_" value="$hash->{$_}">}
  42             unless exists $saves{$_};
  43     }
  44 }
  45
  46 sub Entity (@) {
  47     my $ref;
  48     my @copy;
  49     if (defined wantarray) {
  50         @copy = @_;
  51         $ref = \@copy;
  52     } else {
  53         $ref = \@_;
  54     }
  55     for (@$ref) {
  56         eval {
  57             s/&/&amp;/g;
  58             s/\"/&quot;/g;
  59             s/</&lt;/g;
  60             s/>/&gt;/g;
  61             s/\n/<br>\n/g;
  62             s/\t/&nbsp; &nbsp; &nbsp; &nbsp;&nbsp;/g;
  63             s/  /&nbsp;&nbsp;/g;
  64         };
  65 #       if ($@){ return defined wantarray ? @_ : undef }
  66     }
  67     return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
  68 }
  69
  70 # Browsers do s/ /+/ - I don't care about RFC's, but I do care about real-life
  71 # situations.
  72 sub DecodeURI (@) {
  73     my @r;
  74     local $_;
  75     for (@_) {
  76         s/\+/%20/g;
  77         my $dec = $_;
  78         $dec =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
  79         if (defined wantarray) {
  80             push @r, $dec;
  81         } else {
  82             eval {$_ = $dec};
  83 #           return undef if $@; # ;DecodeURI("foo");
  84         }
  85     }
  86     return defined wantarray ? (wantarray ? @r : "@r") : undef;
  87 }
  88 sub EncodeURI (@) {
  89     my @r;
  90     local $_;
  91     for (@_) {
  92         my $esc = $_;
  93         $esc =~
  94             s{
  95                 ([^\/?:@\$,A-Za-z0-9\-_.!~*\'()])
  96             }{
  97                 sprintf("%%%02x", ord($1))
  98             }xge;
  99         if (defined wantarray) {
 100             push @r, $esc;
 101         } else {
 102             eval {$_ = $esc};
 103 #           return undef if $@; # ;EncodeURI("foo");
 104         }
 105     }
 106     return defined wantarray ? (wantarray ? @r : "@r") : undef;
 107 }
 108
 109 sub AddCookie ($) {
 110     if ($PLP::Script::header{'Set-Cookie'}) {
 111         $PLP::Script::header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]";
 112     } else {
 113         $PLP::Script::header{'Set-Cookie'} = $_[0];
 114     }
 115 }
 116
 117 sub ReadFile ($) {
 118     local $/ = undef;
 119     open (my $fh, '<', $_[0]) or do {
 120         PLP::error("Cannot open $_[0] for reading ($!)", 1);
 121         return undef;
 122     };
 123     my $r = readline $fh;
 124     close $fh;
 125     return $r;
 126 }
 127
 128 sub WriteFile ($$) {
 129     open (my $fh, '>', $_[0]) or do {
 130         PLP::error("Cannot open $_[0] for writing ($!)", 1);
 131         return undef;
 132     };
 133     flock $fh, LOCK_EX;
 134     print $fh $_[1] or do {
 135         PLP::error("Cannot write to $_[0] ($!)");
 136         return undef;
 137     };
 138     close $fh or do {
 139         PLP::error("Cannot close $_[0] ($!)");
 140         return undef;
 141     };
 142     return 1;
 143 }
 144
 145 sub Counter ($) {
 146     local $/ = undef;
 147     my             $fh;
 148     open           $fh, '+<', $_[0] or
 149     open           $fh, '>',  $_[0] or return undef;
 150     flock          $fh, 2;
 151     seek           $fh, 0, 0;
 152     my $counter = <$fh>;
 153     seek           $fh, 0, 0;
 154     truncate       $fh, 0;
 155     print          $fh ++$counter   or return undef;
 156     close          $fh              or return undef;
 157     return $counter;
 158 }
 159
 160 sub AutoURL ($) {
 161     # This sub assumes your string does not match /(["<>])\cC\1/
 162     my $ref;
 163     if (defined wantarray){
 164         $ref = \(my $copy = $_[0]);
 165     }else{
 166         $ref = \$_[0];
 167     }
 168     eval {
 169         $$ref =~ s/&quot;/"\cC"/g; # Single characters are easier to match :)
 170         $$ref =~ s/&gt;/>\cC>/g;   # so we can just use a character class []
 171         $$ref =~ s/&lt;/<\cC</g;
 172
 173         # Now this is a big, ugly regex! But hey - it works :)
 174         $$ref =~ s{((\w+://|www\.|WWW\.)[a-zA-Z0-9\.\@:-]+[^\"\'>< \r\t\n]*)}{
 175             local $_ = $1;
 176             my $scheme = $2;
 177             s/// if (my $trailing) = /([\.,!\?\(\)\[\]]+$)/;
 178             s/&(?!\x23?\w+;)/&amp;/g;
 179             s/\"/&quot;/g;
 180             my $href = ($scheme =~ /www\./i ? "http://$_" : $_);
 181             qq{<a href="$href" target="_blank">$_</a>$trailing};
 182         }eg;
 183
 184         $$ref =~ s/"\cC"/&quot;/g;
 185         $$ref =~ s/>\cC>/&gt;/g;
 186         $$ref =~ s/<\cC</&lt;/g;
 187     };
 188     if ($@){ return defined wantarray ? @_ : undef }
 189     return defined wantarray ? $$ref : undef;
 190 }
 191
 192 1;
 193
 194 =head1 NAME
 195
 196 PLP::Functions - Functions that are available in PLP documents
 197
 198 =head1 DESCRIPTION
 199
 200 The functions are exported into the PLP::Script package that is used by PLP documents. Although uppercased letters are unusual in Perl, they were chosen to stand out.
 201
 202 Most of these functions are context-hybird. Before using them, one should know about contexts in Perl. The three major contexts are: B<void>, B<scalar> and B<list> context. You'll find more about context in L<perlfunc>.
 203
 204 Some context examples:
 205
 206     print foo();  # foo is in list context (print LIST)
 207     foo();        # foo is in void context
 208     $bar = foo(); # foo is in scalar context
 209     @bar = foo(); # foo is in list context
 210     length foo(); # foo is in scalar context (length EXPR)
 211
 212 =head2 The functions
 213
 214 =over 10
 215
 216 =item Include FILENAME
 217
 218 Executes another PLP file, that will be parsed (i.e. code must be in C<< <: :> >>). As with Perl's C<do>, the file is evaluated in its own lexical file scope, so lexical variables (C<my> 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).
 219
 220 =item include FILENAME
 221
 222 An alias for C<Include>.
 223
 224 =item PLP_END BLOCK
 225
 226 Adds a piece of code that is executed when at the end of the PLP document. This is useful when creating a template file:
 227
 228     <html><body>       <!-- this is template.plp -->
 229     <: PLP_END { :>
 230     </body></html>
 231     <: } :>
 232
 233     <(template.plp)>   <!-- this is index.plp -->
 234     Hello, world!
 235
 236 You should use this function instead of Perl's built-in C<END> blocks, because those do not work properly with mod_perl.
 237
 238 =item Entity LIST
 239
 240 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<HTML::Entity> does.
 241
 242 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 243
 244     <: print Entity($user_input); :>
 245
 246 =item EncodeURI LIST
 247
 248 Replaces characters by their %-encoded values.
 249
 250 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 251
 252     <a href="/foo.plp?name=<:= EncodeURI($name) :>">Link</a>
 253
 254 =item DecodeURI LIST
 255
 256 Decodes %-encoded strings.
 257
 258 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 259
 260 =item ReadFile FILENAME
 261
 262 Returns the contents of FILENAME in one large string. Returns undef on failure.
 263
 264 =item WriteFile FILENAME, STRING
 265
 266 Writes STRING to FILENAME (overwrites FILENAME if it already exists). Returns true on success, false on failure.
 267
 268 =item Counter FILENAME
 269
 270 Increases the contents of FILENAME by one and returns the new value. Returns undef on failure. Fails silently.
 271
 272     You are visitor number <:= Counter('counter.txt') :>.
 273
 274 =item AutoURL STRING
 275
 276 Replaces URLs (actually, replace things that look like URLs) by links.
 277
 278 In void context, B<changes> the value of the given variable. In other contexts, returns the changed version.
 279
 280     <: print AutoURL(Entity($user_input)); :>
 281
 282 =item AddCookie STRING
 283
 284 Adds a Set-Cookie header. STRING must be a valid Set-Cookie header value.
 285
 286 =back
 287
 288 =head1 AUTHOR
 289
 290 Juerd Waalboer <juerd@juerd.nl>
 291
 292 =cut
 293