plptie.pm

   1 #!/usr/bin/perl -- Just for the fscking colors.
   2
   3 package PLP::Headers; # Who cares.
   4 use strict;
   5 use Carp;
   6
   7 sub _lc($){
   8     local $_ = $_[0];
   9     tr/_/-/;
  10     return lc;
  11 }
  12
  13 sub TIEHASH {
  14     return bless [ # Defaults.
  15         {
  16             'Content-Type'  => 'text/html',
  17             'X-PLP-Version' => $ENV{PLP_VERSION},
  18         },
  19         {
  20             'content-type'  => 'Content-Type',
  21             'x-plp-version' => 'X-PLP-Version',
  22         }
  23     ], $_[0];
  24 }
  25
  26 sub FETCH {
  27     my ($self, $key) = @_;
  28     return $self->[0]->{ $self->[1]->{_lc $key} };
  29 }
  30
  31 sub STORE {
  32     my ($self, $key, $value) = @_;
  33     croak 'Can\'t set headers after sending them!' if $main::INTERNAL{sentheaders};
  34     if (defined $self->[1]->{_lc $key}){
  35         $key = $self->[1]->{_lc $key};
  36     }else{
  37         $self->[1]->{lc $key} = $key;
  38     }
  39     return ($self->[0]->{$key} = $value);
  40 }
  41
  42 sub DELETE {
  43     my ($self, $key) = @_;
  44     delete $self->[0]->{$key};
  45     return delete $self->[1]->{_lc $key};
  46 }
  47
  48 sub CLEAR {
  49     my $self = $_[0];
  50     return (@$self = ());
  51 }
  52
  53 sub EXISTS {
  54     my ($self, $key) = @_;
  55     return exists $self->[1]->{_lc $key};
  56 }
  57
  58 sub FIRSTKEY {
  59     my $self = $_[0];
  60     keys %{$self->[0]};
  61     return each %{ $self->[0] }; # Key only, Tie::Hash doc is wrong.
  62 }
  63
  64 sub NEXTKEY {
  65     return each %{ $_[0]->[0] };
  66 }
  67
  68 package PLP::Print;
  69 use strict;
  70
  71 sub TIEHANDLE {
  72     return bless {}, $_[0];
  73 }
  74
  75 sub WRITE { undef; }
  76
  77 sub PRINT {
  78     my ($self, @param) = @_;
  79     main::SendHeaders() unless $main::INTERNAL{sentheaders};
  80     print STDOUT @param;
  81 }
  82
  83 sub PRINTF {
  84     my ($self, @param) = @_;
  85     printf STDOUT @param;
  86 }
  87
  88 sub READ { undef }
  89
  90 sub READLINE { undef }
  91
  92 sub GETC { '%' }
  93
  94 sub CLOSE { undef }
  95
  96 sub UNTIE { undef }
  97
  98 package PLP::Delay;
  99 use strict;
 100 no strict 'refs';
 101
 102 sub _replace {
 103     my ($self) = @_;
 104     untie %{$self->[0]};
 105     %{$self->[0]} = %{ $self->[1]->() };
 106 }
 107
 108 sub TIEHASH {
 109     my ($class, $hash, $source) = @_;
 110     return bless [$hash, $source], $class;
 111 }
 112
 113 sub FETCH {
 114     my ($self, $key) = @_;
 115     $self->_replace;
 116     return ${$self->[0]}{$key};
 117 }
 118
 119 sub STORE {
 120     my ($self, $key, $value) = @_;
 121     $self->_replace;
 122     return ${$self->[0]}{$key} = $value;
 123 }
 124
 125 sub DELETE {
 126     my ($self, $key) = @_;
 127     $self->_replace;
 128     return delete ${$self->[0]}{key};
 129 }
 130
 131 sub CLEAR {
 132     my ($self) = @_;
 133     $self->_replace;
 134     return %{$self->[0]};
 135 }
 136
 137 sub EXISTS {
 138     my ($self, $key) = @_;
 139     $self->_replace;
 140     return exists ${$self->[0]}{key};
 141 }
 142
 143 sub FIRSTKEY {
 144     my ($self) = @_;
 145     $self->_replace;
 146     return exists ${$self->[0]}{key};
 147 }
 148
 149 sub FIRSTKEY {
 150     my ($self) = @_;
 151     $self->_replace;
 152     return 'PLPdummy'; # perl won't use the first key's value,
 153                        # damnit
 154 }
 155
 156 sub NEXTKEY {
 157     my ($self) = @_;
 158     $self->_replace;
 159     return each %$$self;
 160 }
 161
 162 sub UNTIE { undef }
 163
 164 1;