lib/PLP/Functions.pm

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