PLP/Functions.pm

   1 #-------------------------#
   2   package PLP::Functions;
   3 #-------------------------#
   4 use base 'Exporter';
   5 use strict;
   6
   7 our @EXPORT = qw/HiddenFields Entity DecodeURI EncodeURI Entity include
   8                  AddCookie ReadFile WriteFile AutoURL Counter Include/;
   9
  10 sub Include ($) {
  11     my ($file) = $_[0];
  12     $PLP::inA = 0;
  13     $PLP::inB = 0;
  14     eval PLP::source($file, 0);
  15 }
  16
  17 sub include ($) {
  18     goto &Include;
  19 }
  20
  21 sub HiddenFields ($@) {
  22     my $hash = shift;
  23     my %saves;
  24     @saves{@_} = ();
  25     for (keys %$hash) {
  26         print qq{<input type=hidden name="$_" value="$hash->{$_}">}
  27             unless exists $saves{$_};
  28     }
  29 }
  30
  31 sub Entity (@) {
  32     my $ref;
  33     my @copy;
  34     if (defined wantarray) {
  35         @copy = @_;
  36         $ref = \@copy;
  37     } else {
  38         $ref = \@_;
  39     }
  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 #       if ($@){ return defined wantarray ? @_ : undef }
  51     }
  52     return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef;
  53 }
  54
  55 # Browsers do s/ /+/ - I don't care about RFC's, but I do care about real-life
  56 # situations.
  57 sub DecodeURI (@) {
  58     my @r;
  59     local $_;
  60     for (@_) {
  61         s/\+/%20/g;
  62         my $dec = $_;
  63         $dec =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
  64         if (defined wantarray) {
  65             push @r, $dec;
  66         } else {
  67             eval {$_ = $dec};
  68 #           return undef if $@; # ;DecodeURI("foo");
  69         }
  70     }
  71     return defined wantarray ? (wantarray ? @r : "@r") : undef;
  72 }
  73 sub EncodeURI (@) {
  74     my @r;
  75     local $_;
  76     for (@_) {
  77         my $esc = $_;
  78         $esc =~
  79             s{
  80                 ([^\/?:@\$,A-Za-z0-9\-_.!~*\'()])
  81             }{
  82                 sprintf("%%%02x", ord($1))
  83             }xge;
  84         if (defined wantarray) {
  85             push @r, $esc;
  86         } else {
  87             eval {$_ = $esc};
  88 #           return undef if $@; # ;EncodeURI("foo");
  89         }
  90     }
  91     return defined wantarray ? (wantarray ? @r : "@r") : undef;
  92 }
  93
  94 sub AddCookie ($) {
  95     if ($PLP::Script::header{'Set-Cookie'}) {
  96         $PLP::Script::header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]";
  97     } else {
  98         $PLP::Script::header{'Set-Cookie'} = $_[0];
  99     }
 100 }
 101
 102 sub ReadFile ($) {
 103     local *READFILE;
 104     local $/ = undef;
 105     open (READFILE, '<', $_[0]);
 106     my $r = <READFILE>;
 107     close READFILE;
 108     return $r;
 109 }
 110
 111 sub WriteFile ($$) {
 112     local *WRITEFILE;
 113     open (WRITEFILE, '>', $_[0]);
 114     flock WRITEFILE, 2;
 115     print WRITEFILE $_[1];
 116     close WRITEFILE;
 117 }
 118
 119 sub Counter ($) {
 120     local *COUNTER;
 121     local $/ = undef;
 122     open           COUNTER, "+<$_[0]" or
 123     open           COUNTER, ">$_[0]"  or return undef;
 124     flock          COUNTER, 2;
 125     seek           COUNTER, 0, 0;
 126     my $counter = <COUNTER>;
 127     seek           COUNTER, 0, 0;
 128     truncate       COUNTER, 0;
 129     print          COUNTER ++$counter;
 130     close          COUNTER;
 131     return $counter;
 132 }
 133
 134 sub AutoURL ($) {
 135     # This sub assumes your string does not match /(["<>])\cC\1/
 136     my $ref;
 137     if (defined wantarray){
 138         $ref = \(my $copy = $_[0]);
 139     }else{
 140         $ref = \$_[0];
 141     }
 142     eval {
 143         $$ref =~ s/&quot;/"\cC"/g; # Single characters are easier to match :)
 144         $$ref =~ s/&gt;/>\cC>/g;   # so we can just use a character class []
 145         $$ref =~ s/&lt;/<\cC</g;
 146
 147         # Now this is a big, ugly regex! But hey - it works :)
 148         $$ref =~ s{((\w+://|www\.|WWW\.)[a-zA-Z0-9\.\@:-]+[^\"\'>< \r\t\n]*)}{
 149             local $_ = $1;
 150             my $scheme = $2;
 151             s/// if (my $trailing) = /([\.,!\?\(\)\[\]]+$)/;
 152             s/&(?!\x23?\w+;)/&amp;/g;
 153             s/\"/&quot;/g;
 154             my $href = ($scheme =~ /www\./i ? "http://$_" : $_);
 155             qq{<a href="$href" target="_blank">$_</a>$trailing};
 156         }eg;
 157
 158         $$ref =~ s/"\cC"/&quot;/g;
 159         $$ref =~ s/>\cC>/&gt;/g;
 160         $$ref =~ s/<\cC</&lt;/g;
 161     };
 162     if ($@){ return defined wantarray ? @_ : undef }
 163     return defined wantarray ? $$ref : undef;
 164 }
 165
 166
 167 1;