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 include PLP_END
   8                  AddCookie ReadFile WriteFile AutoURL Counter 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 = defined wantarray ? [@_] : \@_;
  37         for (@$ref) {
  38                 eval {
  39                         s/&/&amp;/g;
  40                         s/"/&quot;/g;
  41                         s/</&lt;/g;
  42                         s/>/&gt;/g;
  43                         s/\n/<br>\n/g;
  44                         s/\t/&nbsp; &nbsp; &nbsp; &nbsp;&nbsp;/g;
  45                         s/  /&nbsp;&nbsp;/g;
  46                 };
  47         }
  48         return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
  49 }
  50
  51 sub DecodeURI (@) {
  52         my $ref = defined wantarray ? [@_] : \@_;
  53         for (@$ref) {
  54                 eval {
  55                         tr/+/ /;  # Browsers do tr/ /+/ - I don't care about RFCs, but
  56                                   # I do care about real-life situations.
  57                         s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
  58                 };
  59         }
  60         return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
  61 }
  62
  63 sub EncodeURI (@) {
  64         my $ref = defined wantarray ? [@_] : \@_;
  65         for (@$ref) {
  66                 eval {
  67                         s{([^A-Za-z0-9\-_.!~*'()/?:@\$,])}{sprintf("%%%02x", ord $1)}ge;
  68                 };
  69         }
  70         return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
  71 }
  72
  73 sub AddCookie ($) {
  74         if ($PLP::Script::header{'Set-Cookie'}) {
  75                 $PLP::Script::header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]";
  76         } else {
  77                 $PLP::Script::header{'Set-Cookie'} = $_[0];
  78         }
  79 }
  80
  81 sub ReadFile ($) {
  82         local $/ = undef;
  83         open (my $fh, '<', $_[0]) or do {
  84                 PLP::error("Cannot open $_[0] for reading ($!)", 1);
  85                 return undef;
  86         };
  87         my $r = readline $fh;
  88         close $fh;
  89         return $r;
  90 }
  91
  92 sub WriteFile ($$) {
  93         open (my $fh, '>', $_[0]) or do {
  94                 PLP::error("Cannot open $_[0] for writing ($!)", 1);
  95                 return undef;
  96         };
  97         flock $fh, LOCK_EX;
  98         print $fh $_[1] or do {
  99                 PLP::error("Cannot write to $_[0] ($!)");
 100                 return undef;
 101         };
 102         close $fh or do {
 103                 PLP::error("Cannot close $_[0] ($!)");
 104                 return undef;
 105         };
 106         return 1;
 107 }
 108
 109 sub Counter ($) {
 110         local $/ = undef;
 111         my             $fh;
 112         open           $fh, '+<', $_[0] or
 113         open           $fh, '>',  $_[0] or return undef;
 114         flock          $fh, 2;
 115         seek           $fh, 0, 0;
 116         my $counter = <$fh>;
 117         seek           $fh, 0, 0;
 118         truncate       $fh, 0;
 119         print          $fh ++$counter   or return undef;
 120         close          $fh              or return undef;
 121         return $counter;
 122 }
 123
 124 sub AutoURL ($) {
 125         # This sub assumes your string does not match /(["<>])\cC\1/
 126         my $ref = defined wantarray ? \(my $copy = $_[0]) : \$_[0];
 127         eval {
 128                 $$ref =~ s/&quot;/"\cC"/g; # Single characters are easier to match :)
 129                 $$ref =~ s/&gt;/>\cC>/g;   # so we can just use a character class []
 130                 $$ref =~ s/&lt;/<\cC</g;
 131
 132                 # Now this is a big, ugly regex! But hey - it works :)
 133                 $$ref =~ s{((\w+://|www\.|WWW\.)[a-zA-Z0-9\.\@:-]+[^\"\'>< \r\t\n]*)}{
 134                         local $_ = $1;
 135                         my $scheme = $2;
 136                         s/// if (my $trailing) = /([\.,!\?\(\)\[\]]+$)/;
 137                         s/&(?!\x23?\w+;)/&amp;/g;
 138                         s/\"/&quot;/g;
 139                         my $href = ($scheme =~ /www\./i ? "http://$_" : $_);
 140                         qq{<a href="$href" target="_blank">$_</a>$trailing};
 141                 }eg;
 142
 143                 $$ref =~ s/"\cC"/&quot;/g;
 144                 $$ref =~ s/>\cC>/&gt;/g;
 145                 $$ref =~ s/<\cC</&lt;/g;
 146         };
 147         if ($@){ return defined wantarray ? @_ : undef }  # return original on error
 148         return defined wantarray ? $$ref : undef;
 149 }
 150
 151 1;
 152
 153 =head1 NAME
 154
 155 PLP::Functions - Functions that are available in PLP documents
 156
 157 =head1 DESCRIPTION
 158
 159 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.
 160
 161 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>.
 162
 163 Some context examples:
 164
 165     print foo();  # foo is in list context (print LIST)
 166     foo();        # foo is in void context
 167     $bar = foo(); # foo is in scalar context
 168     @bar = foo(); # foo is in list context
 169     length foo(); # foo is in scalar context (length EXPR)
 170
 171 =head2 The functions
 172
 173 =over 10
 174
 175 =item Include FILENAME
 176
 177 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).
 178
 179 Include can be used recursively, and there is no depth limit:
 180
 181     <!-- This is crash.plp -->
 182     <:
 183         include 'crash.plp';
 184         # This example will loop forever,
 185         # and dies with an out of memory error.
 186         # Do not try this at home.
 187     :>
 188
 189 =item include FILENAME
 190
 191 An alias for C<Include>.
 192
 193 =item PLP_END BLOCK
 194
 195 Adds a piece of code that is executed when at the end of the PLP document. This is useful when creating a template file:
 196
 197     <html><body>       <!-- this is template.plp -->
 198     <: PLP_END { :>
 199     </body></html>
 200     <: } :>
 201
 202     <(template.plp)>   <!-- this is index.plp -->
 203     Hello, world!
 204
 205 You should use this function instead of Perl's built-in C<END> blocks, because those do not work properly with mod_perl.
 206
 207 =item Entity LIST
 208
 209 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.
 210
 211 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 212
 213     <: print Entity($user_input); :>
 214
 215 Be warned that this function also HTMLizes consecutive whitespace and newlines (using &nbsp; and <br> respectively).
 216 For simple escaping, use L<XML::Quote|XML::Quote>.
 217 To escape high-bit characters as well, use L<HTML::Entities|HTML::Entities>.
 218
 219 =item EncodeURI LIST
 220
 221 Encodes URI strings according to RFC 3986. All disallowed characters are replaced by their %-encoded values.
 222
 223 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 224
 225     <a href="/foo.plp?name=<:= EncodeURI($name) :>">Link</a>
 226
 227 Note that the following reserved characters are I<not> percent-encoded, even though they may have a special meaning in URIs:
 228
 229         / ? : @ $
 230
 231 This should be safe for escaping query values (as in the example above),
 232 but it may be a better idea to use L<URI::Escape|URI::Escape> instead.
 233
 234 =item DecodeURI LIST
 235
 236 Decodes %-encoded strings. Unlike L<URI::Escape|URI::Escape>,
 237 it also translates + characters to spaces (as browsers use those).
 238
 239 In void context, B<changes> the values of the given variables. In other contexts, returns the changed versions.
 240
 241 =item ReadFile FILENAME
 242
 243 Returns the contents of FILENAME in one large string. Returns undef on failure.
 244
 245 =item WriteFile FILENAME, STRING
 246
 247 Writes STRING to FILENAME (overwrites FILENAME if it already exists). Returns true on success, false on failure.
 248
 249 =item Counter FILENAME
 250
 251 Increases the contents of FILENAME by one and returns the new value. Returns undef on failure. Fails silently.
 252
 253     You are visitor number <:= Counter('counter.txt') :>.
 254
 255 =item AutoURL STRING
 256
 257 Replaces URLs (actually, replace things that look like URLs) by links.
 258
 259 In void context, B<changes> the value of the given variable. In other contexts, returns the changed version.
 260
 261     <: print AutoURL(Entity($user_input)); :>
 262
 263 =item AddCookie STRING
 264
 265 Adds a Set-Cookie header. STRING must be a valid Set-Cookie header value.
 266
 267 =back
 268
 269 =head1 AUTHOR
 270
 271 Juerd Waalboer <juerd@cpan.org>
 272
 273 Current maintainer: Mischa POSLAWSKY <shiar@cpan.org>
 274
 275 =cut
 276