X-Git-Url: http://git.shiar.nl/perl/plp/.git/blobdiff_plain/720e78a4f8351eedac26b196aa9f3922fd5bd0ee..b7a10718f1c1e5d0028cd367c337e9f85dc56618:/plptie.pm?ds=sidebyside

diff --git a/plptie.pm b/plptie.pm
new file mode 100644
index 0000000..d96846e
--- /dev/null
+++ b/plptie.pm
@@ -0,0 +1,164 @@
+#!/usr/bin/perl -- Just for the fscking colors.
+
+package PLP::Headers; # Who cares.
+use strict;
+use Carp;
+
+sub _lc($){
+    local $_ = $_[0];
+    tr/_/-/;
+    return lc;
+}
+
+sub TIEHASH {
+    return bless [ # Defaults.
+        {
+    	    'Content-Type'  => 'text/html',
+    	    'X-PLP-Version' => $ENV{PLP_VERSION},
+	},
+	{
+    	    'content-type'  => 'Content-Type',
+    	    'x-plp-version' => 'X-PLP-Version',
+	}
+    ], $_[0];
+}
+
+sub FETCH {
+    my ($self, $key) = @_;
+    return $self->[0]->{ $self->[1]->{_lc $key} };
+}
+
+sub STORE {
+    my ($self, $key, $value) = @_;
+    croak 'Can\'t set headers after sending them!' if $main::INTERNAL{sentheaders};
+    if (defined $self->[1]->{_lc $key}){
+        $key = $self->[1]->{_lc $key};
+    }else{
+        $self->[1]->{lc $key} = $key;
+    }
+    return ($self->[0]->{$key} = $value);
+}
+
+sub DELETE {
+    my ($self, $key) = @_;
+    delete $self->[0]->{$key};
+    return delete $self->[1]->{_lc $key};
+}
+
+sub CLEAR {
+    my $self = $_[0];
+    return (@$self = ());
+}
+
+sub EXISTS {
+    my ($self, $key) = @_;
+    return exists $self->[1]->{_lc $key};
+}
+
+sub FIRSTKEY {
+    my $self = $_[0];
+    keys %{$self->[0]};
+    return each %{ $self->[0] }; # Key only, Tie::Hash doc is wrong.
+}
+
+sub NEXTKEY {
+    return each %{ $_[0]->[0] };
+}
+
+package PLP::Print;
+use strict;
+
+sub TIEHANDLE {
+    return bless {}, $_[0];
+}
+
+sub WRITE { undef; }
+
+sub PRINT {
+    my ($self, @param) = @_;
+    main::SendHeaders() unless $main::INTERNAL{sentheaders};
+    print STDOUT @param;
+}
+
+sub PRINTF {
+    my ($self, @param) = @_;
+    printf STDOUT @param;
+}
+
+sub READ { undef }
+
+sub READLINE { undef }
+
+sub GETC { '%' }
+
+sub CLOSE { undef }
+
+sub UNTIE { undef }
+
+package PLP::Delay;
+use strict;
+no strict 'refs';
+
+sub _replace {
+    my ($self) = @_;
+    untie %{$self->[0]};
+    %{$self->[0]} = %{ $self->[1]->() };
+}
+
+sub TIEHASH {
+    my ($class, $hash, $source) = @_;
+    return bless [$hash, $source], $class;
+}
+
+sub FETCH {
+    my ($self, $key) = @_;
+    $self->_replace;
+    return ${$self->[0]}{$key};
+}
+
+sub STORE {
+    my ($self, $key, $value) = @_;
+    $self->_replace;
+    return ${$self->[0]}{$key} = $value;
+}
+
+sub DELETE {
+    my ($self, $key) = @_;
+    $self->_replace;
+    return delete ${$self->[0]}{key};
+}
+
+sub CLEAR {
+    my ($self) = @_;
+    $self->_replace;
+    return %{$self->[0]};
+}
+
+sub EXISTS {
+    my ($self, $key) = @_;
+    $self->_replace;
+    return exists ${$self->[0]}{key};
+}
+
+sub FIRSTKEY {
+    my ($self) = @_;
+    $self->_replace;
+    return exists ${$self->[0]}{key};
+}
+
+sub FIRSTKEY {
+    my ($self) = @_;
+    $self->_replace;
+    return 'PLPdummy'; # perl won't use the first key's value, 
+                       # damnit
+}
+
+sub NEXTKEY {
+    my ($self) = @_;
+    $self->_replace;
+    return each %$$self;
+}
+
+sub UNTIE { undef }
+
+1;