plpfunc.pm

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