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