--- /dev/null
+package PLP;
+
+# Not to be used without the CGI script;
+
+our $VERSION = '3.00';
+
+use PLP::Functions ();
+use PLP::Fields;
+use PLP::Tie::Headers;
+use PLP::Tie::Delay;
+use PLP::Tie::Print;
+
+sub SendHeaders () {
+ our $sentheaders = 1;
+ print STDOUT "Content-Type: text/plain\n\n" if $DEBUG & 2;
+ print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n";
+};
+
+sub source {
+ my ($path, $level) = @_;
+ our ($inA, $inB);
+ (my $file = $path) =~ s[.*/][];
+ my $source = $level
+ ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
+ : qq/\n#line 1 "$file"\nprint q\cQ/;
+ my $linenr = 0;
+ local *SOURCE;
+ open SOURCE, $path or return $level
+ ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ}
+ : qq{\ndie qq[Can't open "\Q$path\e" (\Q$!\E)];};
+ LINE: while (defined (my $line = <SOURCE>)) {
+ $linenr++;
+ for (;;) {
+ $line =~ /
+ \G # Begin where left off
+ ( \z # End
+ | <:=? | :> # PLP tags <:=? ... :>
+ | <\(.*?\)> # Include tags <(...)>
+ | <[^:(][^<:]* # Normal text
+ | :[^>][^<:]* # Normal text
+ | [^<:]* # Normal text
+ )
+ /gxs;
+ next LINE unless length $1;
+ my $part = $1;
+ if ($part eq '<:=' and not $inA || $inB) {
+ $inA = 1;
+ $source .= "\cQ, ";
+ } elsif ($part eq '<:' and not $inA || $inB) {
+ $inB = 1;
+ $source .= "\cQ; ";
+ } elsif ($part eq ':>' and $inA) {
+ $inA = 0;
+ $source .= ", q\cQ";
+ } elsif ($part eq ':>' and $inB) {
+ $inB = 0;
+ $source .= "; print q\cQ";
+ } elsif ($part =~ /^<\((.*?)\)>\z/ and not $inA || $inB) {
+ $source .= source($1, $level + 1) .
+ qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
+ } else {
+ $part =~ s/\\/\\\\/ if not $inA || $inB;
+ $source .= $part;
+ }
+ }
+ }
+ $source .= "\cQ" unless $level;
+ return $source;
+}
+
+1;
+
--- /dev/null
+#----------------------#
+ package PLP::Fields;
+#----------------------#
+use strict;
+
+=head1 PLP::Fields
+
+Has only one function: doit(), which ties the hashes %get, %post, %fields and %header in
+PLP::Script. Also generates %cookie immediately.
+
+ PLP::Fields::doit();
+
+=cut
+
+sub doit {
+ tie %PLP::Script::get, 'PLP::Tie::Delay', 'PLP::Script::get', sub {
+ my %get;
+ if ($ENV{QUERY_STRING} ne ''){
+ for (split /[&;]/, $ENV{QUERY_STRING}) {
+ my @keyval = split /=/;
+ PLP::Functions::DecodeURI(@keyval);
+ $get{$keyval[0]} = $keyval[1] unless $keyval[0] =~ /^\@/;
+ push @{ $get{'@' . $keyval[0]} }, $keyval[1];
+ }
+ }
+ return \%get;
+ };
+
+ tie %PLP::Script::post, 'PLP::Tie::Delay', 'PLP::Script::post', sub {
+ my %post;
+ our $post = <STDIN>;
+ if (defined($post) && $post ne '' &&
+ ($ENV{CONTENT_TYPE} eq '' || $ENV{CONTENT_TYPE} eq 'application/x-www-form-urlencoded')){
+ for (split /[&;]/, $post) {
+ my @keyval = split /=/;
+ PLP::Functions::DecodeURI(@keyval);
+ $post{$keyval[0]} = $keyval[1] unless $keyval[0] =~ /^\@/;
+ push @{ $post{'@' . $keyval[0]} }, $keyval[1];
+ }
+ }
+ return \%post;
+ };
+
+ tie %PLP::Script::fields, 'PLP::Tie::Delay', 'PLP::Script::fields', sub {
+ $PLP::Script::get{PLPdummy}, $PLP::Script::post{PLPdummy}; # Trigger creation
+ return {%PLP::Script::get, %PLP::Script::post}
+ };
+
+ tie %PLP::Script::header, 'PLP::Tie::Headers';
+
+ if (defined($ENV{HTTP_COOKIE}) && $ENV{HTTP_COOKIE} ne ''){
+ for (split /; ?/, $ENV{HTTP_COOKIE}) {
+ my @keyval = split /=/;
+ $PLP::Script::cookie{$keyval[0]} ||= $keyval[1];
+ }
+ }
+
+}
+1;
-#!/usr/bin/perl
-# The shebang is only there for mcedit syntax highlights, as I'm too lazy to
-# change the configfile. It won't hurt performance
+#-------------------------#
+ package PLP::Functions;
+#-------------------------#
+use base 'Exporter';
+use strict;
-#use URI::Escape;
+our @EXPORT = qw/HiddenFields Entity DecodeURI EncodeURI Entity include
+ AddCookie ReadFile WriteFile AutoURL Counter Include/;
-use strict;
-use vars qw(%header);
+sub Include ($) {
+ my ($file) = $_[0];
+ $PLP::inA = 0;
+ $PLP::inB = 0;
+ eval PLP::source($file, 0);
+}
+
+sub include ($) {
+ goto &Include;
+}
-sub HiddenFields($@){
+sub HiddenFields ($@) {
my $hash = shift;
my %saves;
@saves{@_} = ();
- for (keys %$hash){
+ for (keys %$hash) {
print qq{<input type=hidden name="$_" value="$hash->{$_}">}
unless exists $saves{$_};
}
}
-sub Entity(@){
+sub Entity (@) {
my $ref;
my @copy;
- if (defined wantarray){
+ if (defined wantarray) {
@copy = @_;
$ref = \@copy;
- }else{
+ } else {
$ref = \@_;
}
- for (@$ref){
+ for (@$ref) {
eval {
s/&/&/g;
s/\"/"/g;
# Browsers do s/ /+/ - I don't care about RFC's, but I do care about real-life
# situations.
-sub DecodeURI(@){
+sub DecodeURI (@) {
my @r;
local $_;
- for (@_){
+ for (@_) {
s/\+/%20/g;
my $dec = $_;
$dec =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
- if (defined wantarray){
+ if (defined wantarray) {
push @r, $dec;
- }else{
+ } else {
eval {$_ = $dec};
# return undef if $@; # ;DecodeURI("foo");
}
}
return defined wantarray ? (wantarray ? @r : "@r") : undef;
}
-sub EncodeURI(@){
+sub EncodeURI (@) {
my @r;
local $_;
- for (@_){
+ for (@_) {
my $esc = $_;
$esc =~
s{
- ([^;\/?:@&=\$,A-Za-z0-9\-_.!~*\'()])
+ ([^\/?:@\$,A-Za-z0-9\-_.!~*\'()])
}{
sprintf("%%%02x", ord($1))
}xge;
- if (defined wantarray){
+ if (defined wantarray) {
push @r, $esc;
- }else{
+ } else {
eval {$_ = $esc};
# return undef if $@; # ;EncodeURI("foo");
}
return defined wantarray ? (wantarray ? @r : "@r") : undef;
}
-sub AddCookie($){
- if ($header{'Set-Cookie'}){
- $header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]";
- }else{
- $header{'Set-Cookie'} = $_[0];
+sub AddCookie ($) {
+ if ($PLP::Script::header{'Set-Cookie'}) {
+ $PLP::Script::header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]";
+ } else {
+ $PLP::Script::header{'Set-Cookie'} = $_[0];
}
}
-sub ReadFile($){
+sub ReadFile ($) {
local *READFILE;
local $/ = undef;
- open (READFILE, "<$_[0]");
+ open (READFILE, '<', $_[0]);
my $r = <READFILE>;
close READFILE;
return $r;
}
-sub WriteFile($$){
+sub WriteFile ($$) {
local *WRITEFILE;
- open (WRITEFILE, ">$_[0]");
+ open (WRITEFILE, '>', $_[0]);
flock WRITEFILE, 2;
print WRITEFILE $_[1];
close WRITEFILE;
}
-sub Counter($){
+sub Counter ($) {
local *COUNTER;
local $/ = undef;
open COUNTER, "+<$_[0]" or
return $counter;
}
-sub AutoURL($){
+sub AutoURL ($) {
# This sub assumes your string does not match /(["<>])\cC\1/
my $ref;
if (defined wantarray){
if ($@){ return defined wantarray ? @_ : undef }
return defined wantarray ? $$ref : undef;
}
+
+
1;
--- /dev/null
+#--------------------------#
+ package PLP::Tie::Delay;
+#--------------------------#
+use strict;
+no strict 'refs';
+
+=head1 PLP::Tie::Delay
+
+Delays hash generation. Unties the hash on first access, and replaces it by the generated one.
+Uses symbolic references, because circular ties make Perl go nuts :)
+
+ tie %Some::hash, 'PLP::Tie::Delay', 'Some::hash', sub { \%generated_hash };
+
+=cut
+
+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 NEXTKEY {
+ my ($self) = @_;
+ $self->_replace;
+ return each %$$self;
+}
+
+sub UNTIE { }
+sub DESTORY { }
+
+1;
+
--- /dev/null
+#----------------------------#
+ package PLP::Tie::Headers;
+#----------------------------#
+use strict;
+use Carp;
+
+=head1 PLP::Tie::Headers
+
+Makes a hash case insensitive, and sets some headers. <_> equals <->, so C<$foo{CONTENT_TYPE}> is
+the same as C<$foo{'Content-Type'}>.
+
+ tie %somehash, 'PLP::Tie::Headers';
+
+=cut
+
+sub _lc($) {
+ local $_ = $_[0];
+ tr/_/-/;
+ return lc;
+}
+
+sub TIEHASH {
+ return bless [ # Defaults.
+ {
+ 'Content-Type' => 'text/html',
+ 'X-PLP-Version' => $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 $PLP::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] };
+}
+
+1;
+
--- /dev/null
+#--------------------#
+ package PLP::Tie::Print;
+#--------------------#
+use strict;
+
+=head1 PLP::Tie::Print
+
+Just prints to stdout, but sends headers if not sent before.
+
+ tie *HANDLE, 'PLP::Tie::Print';
+
+=cut
+
+sub TIEHANDLE {
+ return bless {}, $_[0];
+}
+
+sub WRITE { undef; }
+
+sub PRINT {
+ my ($self, @param) = @_;
+ PLP::SendHeaders() unless $PLP::sentheaders;
+ print STDOUT @param;
+ select STDOUT;
+}
+
+sub PRINTF {
+ my ($self, @param) = @_;
+ printf STDOUT @param;
+ select STDOUT;
+}
+
+sub READ { undef }
+
+sub READLINE { undef }
+
+sub GETC { '%' }
+
+sub CLOSE { undef }
+
+sub UNTIE { undef }
+
+1;
+
#!/usr/local/bin/perl
+use v5.6.0;
+use PLP;
-use vars qw(%INTERNAL %get %post %fields %header %cookie %BLOCK $DEBUG $output);
-use strict;
+die 'Wrong module version' if $PLP::VERSION ne '3.00';
-sub SendHeaders(){
- $INTERNAL{sentheaders} = 1;
- print STDOUT "Content-Type: text/plain\n\n" if $DEBUG & 2;
- print STDOUT map("$_: $header{$_}\n", keys %header), "\n";
-};
+use vars qw($DEBUG);
-sub rawprint(@){
- print STDOUT (@_);
+use strict;
+{
+ $PLP::code = '';
+ $PLP::sentheaders = 0;
+ $PLP::inA = 0;
+ $PLP::inB = 0;
}
-
-$ENV{PLP_VERSION} = '2.40';
$DEBUG = 1;
+our $mod_perl = exists $ENV{MOD_PERL};
-# We put most everything in %INTERNAL, just so the user won't screw it.
-# We could also have used packages, but let's keep it simple.
-
-$INTERNAL{file} = $ENV{PATH_TRANSLATED};
-unless (-e $INTERNAL{file}){
- $ENV{REDIRECT_STATUS} = '404';
- print STDERR "PLP: Not found: $INTERNAL{file}\n";
-
- #Change this if you have an error handling script.
- print `/vhost/COMMON/err.cgi` || "Status: 404 Not found\n\nFile not found";
+{
+ my $file = $ENV{PATH_TRANSLATED};
+ $ENV{PLP_NAME} = $ENV{PATH_INFO};
+ my $path_info;
+ while (not -f $file) {
+ if (not $file =~ s/(\/+[^\/]*)$//) {
+ $ENV{REDIRECT_STATUS} = '404';
+ print STDERR "PLP: Not found: $file\n";
+
+ if ($mod_perl) {
+ Apache->request->uri($ENV{REQUEST_URI});
+ print STDOUT "Status: 404 Not Found";
+ Apache::exit();
+ } else {
+ print STDOUT "Status: 404 Not Found\n\nNot found: $ENV{REQUEST_URI}";
+ exit;
+ }
+ }
+ my $pi = $1;
+ $ENV{PLP_NAME} =~ s/\Q$pi\E$//;
+ $path_info = $pi . $path_info;
+ }
- exit;
-}
-
-require plp;
-
-($INTERNAL{dir} = $INTERNAL{file}) =~ s{^(.*)/(.*?)$}[$1];
-$ENV{FILE_NAME} = $2;
-chdir $INTERNAL{dir};
-
-($ENV{PLP_NAME} = $ENV{REQUEST_URI}) =~ s/\?.*$//;
-
-
-$INTERNAL{qq} = "\10"; #^P
-$INTERNAL{q} = "\17"; #^Q
-
-$INTERNAL{code} = ReadFile($INTERNAL{file});
-
-while ($INTERNAL{code} =~ /<\((.*?)\)>/ ){
- (my $file = $1) =~ tr/[<>|//d;
- $INTERNAL{code} =~ s//ReadFile($file)/e;
-}
-
-$INTERNAL{code} =~ s(<:)($INTERNAL{q};)g;
-$INTERNAL{code} =~ s(:>)(;\nprint q$INTERNAL{q})g;
-
-while ($INTERNAL{code} =~ /(<\[1(.*?)\]>(.*?)<\[2\]>(.*?)<\[3\]>)/s){
- $BLOCK{"$2-1"} = $3;
- $BLOCK{"$2-2"} = $4;
- $INTERNAL{code} =~ s///; #Redo last match
-}
-$INTERNAL{code} =~ s(\\\\\r?\n)()g;
-
-# This is bad and subject to removal.
-$INTERNAL{code} =~ s(<\[([^>]*?):(.*?)\]>)($BLOCK{"${1}-1"}$2$BLOCK{"${1}-2"})g;
-$INTERNAL{code} =~ s(<\[(?!/)(.*?)\]>)($BLOCK{"${1}-1"})g;
-$INTERNAL{code} =~ s(<\[/(.*?)\]>)($BLOCK{"${1}-2"})g;
+ if ($mod_perl) {
+ Apache->request->uri($ENV{REQUEST_URI});
+ }
-# This too is bad and subject to removal.
-$INTERNAL{code} =~ s(<{[ \08\09]*)($INTERNAL{q};print qq$INTERNAL{qq})g;
-$INTERNAL{code} =~ s([ \08\09]*}>)($INTERNAL{qq};print q$INTERNAL{q})g;
-$INTERNAL{code} = "print q$INTERNAL{q}$INTERNAL{code}$INTERNAL{q};";
+ if (not -r $file) {
+ if (exists $ENV{MOD_PERL}) {
+ print STDOUT "Status: 403 Forbidden";
+ Apache::exit();
+ } else {
+ print STDOUT "Status: 403 Forbidden\n\nForbidden: $ENV{REQUEST_URI}";
+ exit;
+ }
+ }
-$INTERNAL{code} =~ s{print qq$INTERNAL{qq}$INTERNAL{qq};}[]g;
-$INTERNAL{code} =~ s{print q$INTERNAL{q}$INTERNAL{q};}[]g;
+ delete @ENV{
+ qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO),
+ grep { /^REDIRECT_/ } keys %ENV
+ };
-tie %header, 'PLP::Headers';
-tie *PLPOUT, 'PLP::Print';
+ $ENV{PATH_INFO} = $path_info if defined $path_info;
+ $ENV{PLP_FILENAME} = $file;
+ (my $dir = $file) =~ s{/[^/]+$}[];
+ chdir $dir;
-# This is VERY bad, and will probably be removed. Use <: BEGIN { ... }
-# :> instead
-while ($INTERNAL{code} =~ s/<_(.*?)_>//s){
- $INTERNAL{pre} = $1;
- {
- no strict;
- eval $INTERNAL{pre};
- if ($@ && $DEBUG & 1){
- print "\nDebug:\n $@";
- }
- }
+ $PLP::code = PLP::source($file, 0);
+ tie *PLPOUT, 'PLP::Tie::Print';
+ select PLPOUT;
}
-#$INTERNAL{headers}->();
-select PLPOUT;
{
no strict;
- eval $INTERNAL{code};
- SendHeaders() unless $INTERNAL{sentheaders};
+ PLP::Fields::doit();
+ {
+ package PLP::Script;
+ *headers = \%header;
+ *cookies = \%cookie;
+ PLP::Functions->import();
+ eval qq{package PLP::Script; $PLP::code};
+ }
+ select STDOUT;
+ undef *{"PLP::Script::$_"} for keys %PLP::Script::;
+ PLP::SendHeaders() unless $PLP::sentheaders;
if ($@ && $DEBUG & 1){
- print "<hr><b>Debug</b><br>", Entity($@);
+ print $header{'Content-Type'} =~ m!^text/html!i
+ ? ("<hr><b>Debug</b><br>", Entity($@))
+ : ("[Debug]\n", $@);
}
}
+
+++ /dev/null
-use plpfunc;
-use plptie;
-use plpfields;
-1;
\ No newline at end of file
+++ /dev/null
-#!/usr/bin/perl
-# shebang only for color coding, just ignore it m'kay?
-use strict;
-use vars qw(%get %post %fields %cookie %INTERNAL);
-
-$INTERNAL{getsub} = sub {
- my %get;
- if ($ENV{QUERY_STRING} ne ''){
- for (split /&/, $ENV{QUERY_STRING}) {
- my @keyval = split /=/;
- DecodeURI(@keyval);
- $get{$keyval[0]} = $keyval[1];
- }
- }
- return \%get;
-};
-
-$INTERNAL{postsub} = sub {
- my %post;
- $INTERNAL{post} = <STDIN>;
- if (defined($INTERNAL{post}) && $INTERNAL{post} ne '' &&
- ($ENV{CONTENT_TYPE} eq '' || $ENV{CONTENT_TYPE} eq 'application/x-www-form-urlencoded')){
- for (split /&/, $INTERNAL{post}) {
- my @keyval = split /=/;
- DecodeURI(@keyval);
- $post{$keyval[0]} = $keyval[1];
- }
- }
- return \%post;
-};
-
-$INTERNAL{fieldssub} = sub {
- $get{PLPdummy}, $post{PLPdummy}; # Trigger creation
- return {%get, %post}
-};
-
-tie %get, 'PLP::Delay', 'main::get', $INTERNAL{getsub};
-tie %post, 'PLP::Delay', 'main::post', $INTERNAL{postsub};
-tie %fields, 'PLP::Delay', 'main::fields', $INTERNAL{fieldssub};
-
-#%fields = (%get, %post);
-
-if (defined($ENV{HTTP_COOKIE}) && $ENV{HTTP_COOKIE} ne ''){
- for (split /; ?/, $ENV{HTTP_COOKIE}) {
- my @keyval = split /=/;
- $cookie{$keyval[0]} ||= $keyval[1];
- }
-}
-
-1;
+++ /dev/null
-#!/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;
git.shiar.nl / perl / plp / .git / commitdiff