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