PLP/Functions.pm

   1 package PLP::Functions;
   2
   3 use base 'Exporter';
   4 use Fcntl qw(:flock);
   5 use strict;
   6
   7 our @EXPORT = qw/Entity DecodeURI EncodeURI include PLP_END
   8                  AddCookie ReadFile WriteFile AutoURL Counter Include exit/;
   9
  10 sub Include ($) {
  11     no strict;
  12     $PLP::file = $_[0];
  13     $PLP::inA = 0;
  14     $PLP::inB = 0;
  15     local $@;
  16     eval 'package PLP::Script; ' . PLP::source($PLP::file, 0, join ' ', (caller)[2,1]);
  17     if ($@) {
  18         PLP::Functions::exit() if $@ =~ /\cS\cT\cO\cP/;
  19         PLP::error($@, 1);
  20     }
  21 }
  22
  23 sub include ($) {
  24     goto &Include;
  25 }
  26
  27 sub exit (;$) {
  28     die "\cS\cT\cO\cP\n";
  29 }
  30
  31 sub PLP_END (&) {
  32     push @PLP::END, shift;
  33 }
  34
  35 sub Entity (@) {
  36     my $ref;
  37     my @copy;
  38     if (defined wantarray) {
  39         @copy = @_;
  40         $ref = \@copy;
  41     } else {
  42         $ref = \@_;
  43     }
  44     for (@$ref) {
  45         eval {
  46             s/&/&amp;/g;
  47             s/\"/&quot;/g;
  48             s/</&lt;/g;
  49             s/>/&gt;/g;
  50             s/\n/<br>\n/g;
  51             s/\t/&nbsp; &nbsp; &nbsp; &nbsp;&nbsp;/g;
  52             s/  /&nbsp;&nbsp;/g;
  53         };
  54 #       if ($@){ return defined wantarray ? @_ : undef }
  55     }
  56     return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
  57 }
  58
  59 sub DecodeURI (@) {
  60     # Browsers do s/ /+/ - I don't care about RFC's, but I do care about real-life
  61     # situations.
  62     my @r;
  63     local $_;
  64     for (@_) {
  65         s/\+/%20/g;
  66         my $dec = $_;
  67         $dec =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
  68         if (defined wantarray) {
  69             push @r, $dec;
  70         } else {
  71             eval {$_ = $dec};
  72 #           return undef if $@; # ;DecodeURI("foo");
  73         }
  74     }
  75     return defined wantarray ? (wantarray ? @r : "@r") : undef;
  76 }
  77
  78 sub EncodeURI (@) {
  79     my @r;
  80     local $_;
  81     for (@_) {
  82         my $esc = $_;
  83         $esc =~
  84             s{
  85                 ([^\/?:@\$,A-Za-z0-9\-_.!~*\'()])
  86             }{
  87                 sprintf("%%%02x", ord($1))
  88             }xge;
  89         if (defined wantarray) {
  90             push @r, $esc;
  91         } else {
  92             eval {$_ = $esc};
  93 #           return undef if $@; # ;EncodeURI("foo");
  94         }
  95     }
  96     return defined wantarray ? (wantarray ? @r : "@r") : undef;
  97 }
  98
  99 sub AddCookie ($) {
 100     if ($PLP::Script::header{'Set-Cookie'}) {
 101         $PLP::Script::header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]";
 102     } else {
 103         $PLP::Script::header{'Set-Cookie'} = $_[0];
 104     }
 105 }
 106
 107 sub ReadFile ($) {
 108     local $/ = undef;
 109     open (my $fh, '<', $_[0]) or do {
 110         PLP::error("Cannot open $_[0] for reading ($!)", 1);
 111         return undef;
 112     };
 113     my $r = readline $fh;
 114     close $fh;
 115     return $r;
 116 }
 117
 118 sub WriteFile ($$) {
 119     open (my $fh, '>', $_[0]) or do {
 120         PLP::error("Cannot open $_[0] for writing ($!)", 1);
 121         return undef;
 122     };
 123     flock $fh, LOCK_EX;
 124     print $fh $_[1] or do {
 125         PLP::error("Cannot write to $_[0] ($!)");
 126         return undef;
 127     };
 128     close $fh or do {
 129         PLP::error("Cannot close $_[0] ($!)");
 130         return undef;
 131     };
 132     return 1;
 133 }
 134
 135 sub Counter ($) {
 136     local $/ = undef;
 137     my             $fh;
 138     open           $fh, '+<', $_[0] or
 139     open           $fh, '>',  $_[0] or return undef;
 140     flock          $fh, 2;
 141     seek           $fh, 0, 0;
 142     my $counter = <$fh>;
 143     seek           $fh, 0, 0;
 144     truncate       $fh, 0;
 145     print          $fh ++$counter   or return undef;
 146     close          $fh              or return undef;
 147     return $counter;
 148 }
 149
 150 sub AutoURL ($) {
 151     # This sub assumes your string does not match /(["<>])\cC\1/
 152     my $ref;
 153     if (defined wantarray){
 154         $ref = \(my $copy = $_[0]);
 155     }else{
 156         $ref = \$_[0];
 157     }
 158     eval {
 159         $$ref =~ s/&quot;/"\cC"/g; # Single characters are easier to match :)
 160         $$ref =~ s/&gt;/>\cC>/g;   # so we can just use a character class []
 161         $$ref =~ s/&lt;/<\cC</g;
 162
 163         # Now this is a big, ugly regex! But hey - it works :)
 164         $$ref =~ s{((\w+://|www\.|WWW\.)[a-zA-Z0-9\.\@:-]+[^\"\'>< \r\t\n]*)}{
 165             local $_ = $1;
 166             my $scheme = $2;
 167             s/// if (my $trailing) = /([\.,!\?\(\)\[\]]+$)/;
 168             s/&(?!\x23?\w+;)/&amp;/g;
 169             s/\"/&quot;/g;
 170             my $href = ($scheme =~ /www\./i ? "http://$_" : $_);
 171             qq{<a href="$href" target="_blank">$_</a>$trailing};
 172         }eg;
 173
 174         $$ref =~ s/"\cC"/&quot;/g;
 175         $$ref =~ s/>\cC>/&gt;/g;
 176         $$ref =~ s/<\cC</&lt;/g;
 177     };
 178     if ($@){ return defined wantarray ? @_ : undef }
 179     return defined wantarray ? $$ref : undef;
 180 }
 181
 182 1;
 183
 184 =head1 NAME
 185
 186 PLP::Functions - Functions that are available in PLP documents
 187
 188 =head1 DESCRIPTION
 189
 190 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.
 191
 192 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>.
 193
 194 Some context examples:
 195
 196     print foo();  # foo is in list context (print LIST)
 197     foo();        # foo is in void context
 198     $bar = foo(); # foo is in scalar context
 199     @bar = foo(); # foo is in list context
 200     length foo(); # foo is in scalar context (length EXPR)
 201
 202 =head2 The functions
 203
 204 =over 10
 205
 206 =item Include FILENAME
 207
 208 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).
 209
 210 Include can be used recursively, and there is no depth limit:
 211
 212     <!-- This is crash.plp -->
 213     <:
 214         include 'crash.plp';
 215         # This example will loop forever,
 216         # and dies with an out of memory error.
 217         # Do not try this at home.
 218     :>
 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 Be warned that this function also HTMLizes consecutive whitespace and newlines (using &nbsp; and <br> respectively).
 247 For simple escaping, use L<XML::Quote>. To escape high-bit characters as well, use L<HTML::Entities>.
 248
 249 =item EncodeURI LIST
 250
 251 Encodes URI strings according to RFC 3986. All disallowed characters are replaced by their %-encoded values.
 252
 253 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 254
 255     <a href="/foo.plp?name=<:= EncodeURI($name) :>">Link</a>
 256
 257 Note that the following reserved characters are I<not> percent-encoded, even though they may have a special meaning in URIs:
 258
 259         / ? : @ $
 260
 261 This should be safe for escaping query values (as in the example above), but it may be a better idea to use L<URI::Escape> instead.
 262
 263 =item DecodeURI LIST
 264
 265 Decodes %-encoded strings. Unlike L<URI::Escape>, it also translates + characters to spaces (as browsers use those).
 266
 267 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 268
 269 =item ReadFile FILENAME
 270
 271 Returns the contents of FILENAME in one large string. Returns undef on failure.
 272
 273 =item WriteFile FILENAME, STRING
 274
 275 Writes STRING to FILENAME (overwrites FILENAME if it already exists). Returns true on success, false on failure.
 276
 277 =item Counter FILENAME
 278
 279 Increases the contents of FILENAME by one and returns the new value. Returns undef on failure. Fails silently.
 280
 281     You are visitor number <:= Counter('counter.txt') :>.
 282
 283 =item AutoURL STRING
 284
 285 Replaces URLs (actually, replace things that look like URLs) by links.
 286
 287 In void context, B<changes> the value of the given variable. In other contexts, returns the changed version.
 288
 289     <: print AutoURL(Entity($user_input)); :>
 290
 291 =item AddCookie STRING
 292
 293 Adds a Set-Cookie header. STRING must be a valid Set-Cookie header value.
 294
 295 =back
 296
 297 =head1 AUTHOR
 298
 299 Juerd Waalboer <juerd@cpan.org>
 300
 301 Current maintainer: Mischa POSLAWSKY <shiar@cpan.org>
 302
 303 =cut
 304