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/HiddenFields Entity DecodeURI EncodeURI Entity 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 HiddenFields ($@) {
  36     my $hash = shift;
  37     my %saves;
  38     @saves{@_} = ();
  39     for (keys %$hash) {
  40         print qq{<input type=hidden name="$_" value="$hash->{$_}">}
  41             unless exists $saves{$_};
  42     }
  43 }
  44
  45 sub Entity (@) {
  46     my $ref;
  47     my @copy;
  48     if (defined wantarray) {
  49         @copy = @_;
  50         $ref = \@copy;
  51     } else {
  52         $ref = \@_;
  53     }
  54     for (@$ref) {
  55         eval {
  56             s/&/&amp;/g;
  57             s/\"/&quot;/g;
  58             s/</&lt;/g;
  59             s/>/&gt;/g;
  60             s/\n/<br>\n/g;
  61             s/\t/&nbsp; &nbsp; &nbsp; &nbsp;&nbsp;/g;
  62             s/  /&nbsp;&nbsp;/g;
  63         };
  64 #       if ($@){ return defined wantarray ? @_ : undef }
  65     }
  66     return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
  67 }
  68
  69 sub DecodeURI (@) {
  70     # Browsers do s/ /+/ - I don't care about RFC's, but I do care about real-life
  71     # situations.
  72     my @r;
  73     local $_;
  74     for (@_) {
  75         s/\+/%20/g;
  76         my $dec = $_;
  77         $dec =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
  78         if (defined wantarray) {
  79             push @r, $dec;
  80         } else {
  81             eval {$_ = $dec};
  82 #           return undef if $@; # ;DecodeURI("foo");
  83         }
  84     }
  85     return defined wantarray ? (wantarray ? @r : "@r") : undef;
  86 }
  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 Include can be used recursively, and there is no depth limit:
 221
 222     <!-- This is crash.plp -->
 223     <:
 224         include 'crash.plp';
 225         # This example will loop forever,
 226         # and dies with an out of memory error.
 227         # Do not try this at home.
 228     :>
 229
 230 =item include FILENAME
 231
 232 An alias for C<Include>.
 233
 234 =item PLP_END BLOCK
 235
 236 Adds a piece of code that is executed when at the end of the PLP document. This is useful when creating a template file:
 237
 238     <html><body>       <!-- this is template.plp -->
 239     <: PLP_END { :>
 240     </body></html>
 241     <: } :>
 242
 243     <(template.plp)>   <!-- this is index.plp -->
 244     Hello, world!
 245
 246 You should use this function instead of Perl's built-in C<END> blocks, because those do not work properly with mod_perl.
 247
 248 =item Entity LIST
 249
 250 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.
 251
 252 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 253
 254     <: print Entity($user_input); :>
 255
 256 =item EncodeURI LIST
 257
 258 Replaces characters by their %-encoded values.
 259
 260 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 261
 262     <a href="/foo.plp?name=<:= EncodeURI($name) :>">Link</a>
 263
 264 =item DecodeURI LIST
 265
 266 Decodes %-encoded strings.
 267
 268 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 269
 270 =item ReadFile FILENAME
 271
 272 Returns the contents of FILENAME in one large string. Returns undef on failure.
 273
 274 =item WriteFile FILENAME, STRING
 275
 276 Writes STRING to FILENAME (overwrites FILENAME if it already exists). Returns true on success, false on failure.
 277
 278 =item Counter FILENAME
 279
 280 Increases the contents of FILENAME by one and returns the new value. Returns undef on failure. Fails silently.
 281
 282     You are visitor number <:= Counter('counter.txt') :>.
 283
 284 =item AutoURL STRING
 285
 286 Replaces URLs (actually, replace things that look like URLs) by links.
 287
 288 In void context, B<changes> the value of the given variable. In other contexts, returns the changed version.
 289
 290     <: print AutoURL(Entity($user_input)); :>
 291
 292 =item AddCookie STRING
 293
 294 Adds a Set-Cookie header. STRING must be a valid Set-Cookie header value.
 295
 296 =back
 297
 298 =head1 AUTHOR
 299
 300 Juerd Waalboer <juerd@cpan.org>
 301
 302 Current maintainer: Mischa POSLAWSKY <shiar@cpan.org>
 303
 304 =cut
 305