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