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