Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

hopts for ($self, name => value) calls

  • Loading branch information...
commit 77218418b98e45238101923dd59e34e81a839770 1 parent f68e846
@jamhed jamhed authored
Showing with 52 additions and 49 deletions.
  1. +52 −49 lib/selfvars.pm
View
101 lib/selfvars.pm
@@ -1,7 +1,7 @@
package selfvars;
use 5.005;
use strict;
-use vars qw( $VERSION $self @args %opts );
+use vars qw( $VERSION $self @args %opts %hopts );
BEGIN {
$VERSION = '0.11';
@@ -9,7 +9,7 @@ BEGIN {
sub import {
my $class = shift; # Oooh, the irony!
- my %vars = (-self => undef, -args => undef, -opts => undef) unless @_;
+ my %vars = (-self => undef, -args => undef, -opts => undef, -hopts => undef) unless @_;
while (@_) {
my $key = shift;
@@ -36,6 +36,10 @@ sub import {
$vars{'-opts'} = 'opts' unless defined $vars{'-opts'};
*{"$pkg\::$vars{'-opts'}"} = \%opts;
}
+ if (exists $vars{'-hopts'}) {
+ $vars{'-hopts'} = 'hopts' unless defined $vars{'-hopts'};
+ *{"$pkg\::$vars{'-hopts'}"} = \%hopts;
+ }
}
package selfvars::self;
@@ -83,40 +87,26 @@ sub _args {
\@DB::args;
}
+sub readonly { require Carp; Carp::croak('Modification of a read-only @args attempted'); }
+
sub TIEARRAY { my $x; bless \$x => $_[0] }
sub FETCHSIZE { scalar $#{ _args() } }
-sub STORESIZE {
- require Carp;
- Carp::croak('Modification of a read-only @args attempted');
- # $#{ _args() } = $_[1] + 1;
-}
+sub STORESIZE { readonly } # $#{ _args() } = $_[1] + 1;
sub STORE { _args()->[ $_[1] + 1 ] = $_[2] }
sub FETCH { _args()->[ $_[1] + 1 ] }
-sub CLEAR {
- require Carp;
- Carp::croak('Modification of a read-only @args attempted');
- # $#{ _args() } = 0;
-}
-sub POP {
- require Carp;
- Carp::croak('Modification of a read-only @args attempted');
- # my $o = _args(); (@$o > 1) ? pop(@$o) : undef
-}
-sub PUSH {
- require Carp;
- Carp::croak('Modification of a read-only @args attempted');
- # my $o = _args(); push( @$o, @_ )
-}
-sub SHIFT {
- require Carp;
- Carp::croak('Modification of a read-only @args attempted');
- # my $o = _args(); splice( @$o, 1, 1 )
-}
-sub UNSHIFT {
- require Carp;
- Carp::croak('Modification of a read-only @args attempted');
- # my $o = _args(); unshift( @$o, @_ )
-}
+sub CLEAR { readonly } # $#{ _args() } = 0;
+sub POP { readonly } # my $o = _args(); (@$o > 1) ? pop(@$o) : undef
+sub PUSH { readonly } # my $o = _args(); push( @$o, @_ )
+sub SHIFT { readonly } # my $o = _args(); splice( @$o, 1, 1 )
+sub UNSHIFT { readonly } # my $o = _args(); unshift( @$o, @_ )
+sub DELETE { readonly } # my $o = _args(); delete $o->[ $_[1] + 1 ]
+sub SPLICE { readonly }
+ # my $ob = shift;
+ # my $sz = $ob->FETCHSIZE;
+ # my $off = @_ ? shift : 0;
+ # $off += $sz if $off < 0;
+ # my $len = @_ ? shift : $sz - $off;
+ # splice( @$ob, $off + 1, $len, @_ );
BEGIN {
local $@;
@@ -127,23 +117,6 @@ BEGIN {
} if $] >= 5.006;
}
-sub DELETE {
- require Carp;
- Carp::croak('Modification of a read-only @args attempted');
- # my $o = _args(); delete $o->[ $_[1] + 1 ]
-}
-
-sub SPLICE {
- require Carp;
- Carp::croak('Modification of a read-only @args attempted');
- # my $ob = shift;
- # my $sz = $ob->FETCHSIZE;
- # my $off = @_ ? shift : 0;
- # $off += $sz if $off < 0;
- # my $len = @_ ? shift : $sz - $off;
- # splice( @$ob, $off + 1, $len, @_ );
-}
-
package selfvars::opts;
sub _opts {
@@ -170,12 +143,42 @@ sub DELETE { my $o = _opts(); delete $o->{$_[1]} }
sub CLEAR { my $o = _opts(); %$o = () }
sub SCALAR { my $o = _opts(); scalar %$o }
+package selfvars::hopts;
+
+sub _opts {
+ my $level = 2;
+ my @c;
+ while ( !defined( $c[3] ) || $c[3] eq '(eval)' ) {
+ @c = do {
+ package DB;
+ @DB::args = ();
+ caller($level);
+ };
+ $level++;
+ }
+ @DB::args;
+}
+
+sub readonly { require Carp; Carp::croak('Modification of a read-only %args attempted'); }
+
+sub TIEHASH { my $x; bless \$x => $_[0] }
+sub FETCH { my (undef, %o) = _opts(); $o{ $_[1] } }
+sub STORE { readonly }
+sub FIRSTKEY { my (undef, %o) = _opts(); my $a = scalar keys %o; each %o }
+sub NEXTKEY { }
+sub EXISTS { my (undef, %o) = _opts(); exists $o{$_[1]} }
+sub DELETE { readonly }
+sub CLEAR { readonly }
+sub SCALAR { my (undef, %o) = _opts(); scalar %o }
+
+
package selfvars;
BEGIN {
tie $self => __PACKAGE__ . '::self';
tie @args => __PACKAGE__ . '::args';
tie %opts => __PACKAGE__ . '::opts';
+ tie %hopts => __PACKAGE__ . '::hopts';
}
1;
Please sign in to comment.
Something went wrong with that request. Please try again.