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