lib/PLP/Functions.pm

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