From: Matt S Trout Date: Sat, 20 Sep 2008 14:20:22 +0000 (+0000) Subject: initial sketch of shadow_sub and hashref-based callback API X-Git-Tag: 0.005000~95 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=840ebcbb85d26ff0acde01d0aeba5cfaa10fb122;p=p5sagit%2FDevel-Declare.git initial sketch of shadow_sub and hashref-based callback API --- diff --git a/Declare.xs b/Declare.xs index c03921f..be8f478 100644 --- a/Declare.xs +++ b/Declare.xs @@ -12,10 +12,18 @@ # define Newx(v,n,t) New(0,v,n,t) #endif /* !Newx */ +#if 1 +#define DD_HAS_TRAITS +#endif + #if 0 #define DD_DEBUG #endif +#define DD_HANDLE_NAME 1 +#define DD_HANDLE_PROTO 2 +#define DD_HANDLE_PACKAGE 8 + #ifdef DD_DEBUG #define DD_DEBUG_S printf("Buffer: %s\n", s); #else @@ -117,7 +125,7 @@ void dd_set_linestr(pTHX_ char* new_value) { } char* dd_get_lex_stuff(pTHX) { - return SvPVX(PL_lex_stuff); + return (PL_lex_stuff ? SvPVX(PL_lex_stuff) : ""); } char* dd_clear_lex_stuff(pTHX) { @@ -128,7 +136,7 @@ char* dd_get_curstash_name(pTHX) { return HvNAME(PL_curstash); } -char* dd_move_past_token(pTHX_ char* s) { +char* dd_move_past_token (pTHX_ char* s) { /* * buffer will be at the beginning of the declarator, -unless- the @@ -142,7 +150,7 @@ char* dd_move_past_token(pTHX_ char* s) { return s; } -int dd_toke_move_past_token(pTHX_ int offset) { +int dd_toke_move_past_token (pTHX_ int offset) { char* base_s = SvPVX(PL_linestr) + offset; char* s = dd_move_past_token(aTHX_ base_s); return s - base_s; @@ -180,10 +188,22 @@ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) { o = dd_old_ck_rv2cv(aTHX_ o); /* let the original do its job */ if (in_declare) { - dSP; - PUSHMARK(SP); - call_pv("Devel::Declare::done_declare", G_VOID|G_DISCARD); - in_declare--; + cb_args[0] = NULL; +#ifdef DD_DEBUG + printf("Deconstructing declare\n"); + printf("PL_bufptr: %s\n", PL_bufptr); + printf("bufend at: %i\n", PL_bufend - PL_bufptr); + printf("linestr: %s\n", SvPVX(PL_linestr)); + printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr)); +#endif + call_argv("Devel::Declare::done_declare", G_VOID|G_DISCARD, cb_args); +#ifdef DD_DEBUG + printf("PL_bufptr: %s\n", PL_bufptr); + printf("bufend at: %i\n", PL_bufend - PL_bufptr); + printf("linestr: %s\n", SvPVX(PL_linestr)); + printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr)); + printf("actual len: %i\n", strlen(PL_bufptr)); +#endif return o; } @@ -195,11 +215,23 @@ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) { if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL) return o; /* not lexing? */ +#ifdef DD_DEBUG + printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), GvNAME(kGVOP_gv)); +#endif + dd_flags = dd_is_declarator(aTHX_ GvNAME(kGVOP_gv)); if (dd_flags == -1) return o; +#ifdef DD_DEBUG + printf("dd_flags are: %i\n", dd_flags); +#endif + +#ifdef DD_DEBUG + printf("PL_tokenbuf: %s\n", PL_tokenbuf); +#endif + dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv)); return o; diff --git a/lib/Devel/Declare.pm b/lib/Devel/Declare.pm index 558074c..72f1f40 100644 --- a/lib/Devel/Declare.pm +++ b/lib/Devel/Declare.pm @@ -51,8 +51,11 @@ sub setup_for { } elsif (ref($info) eq 'CODE') { $flags = DECLARE_NAME; $sub = $info; + } elsif (ref($info) eq 'HASH') { + $flags = 1; + $sub = $info; } else { - die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub"; + die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref"; } $declarators{$target}{$key} = $flags; $declarator_handlers{$target}{$key} = $sub; @@ -77,20 +80,10 @@ sub init_declare { ($temp_name, $temp_save) = ([], []); if ($name) { $name = "${inpack}::${name}" unless $name =~ /::/; - push(@$temp_name, $name); - no strict 'refs'; - push(@$temp_save, \&{$name}); - no warnings 'redefine'; - no warnings 'prototype'; - *{$name} = $name_h; + shadow_sub($name, $name_h); } if ($XX_h) { - push(@$temp_name, "${inpack}::X"); - no strict 'refs'; - push(@$temp_save, \&{"${inpack}::X"}); - no warnings 'redefine'; - no warnings 'prototype'; - *{"${inpack}::X"} = $XX_h; + shadow_sub("${inpack}::X", $XX_h); } if (defined wantarray) { return $extra_code || '0;'; @@ -99,6 +92,19 @@ sub init_declare { } } +sub shadow_sub { + my ($name, $cr) = @_; + push(@$temp_name, $name); + no strict 'refs'; + my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/); + push(@$temp_save, $pack->can($pname)); + delete ${"${pack}::"}{$pname}; + no warnings 'redefine'; + no warnings 'prototype'; + *{$name} = $cr; + set_in_declare(~~@{$temp_name||[]}); +} + sub done_declare { no strict 'refs'; my $name = shift(@{$temp_name||[]}); @@ -111,6 +117,7 @@ sub done_declare { no warnings 'prototype'; *{"${temp_pack}::${name}"} = $saved; } + set_in_declare(~~@{$temp_name||[]}); } sub build_sub_installer { @@ -202,7 +209,6 @@ sub linestr_callback_rv2cv { my $pack = get_curstash_name(); my $flags = $declarators{$pack}{$name}; my ($found_name, $found_proto); - my $in_declare = 0; if ($flags & DECLARE_NAME) { $offset += toke_skipspace($offset); my $linestr = get_linestr(); @@ -213,7 +219,6 @@ sub linestr_callback_rv2cv { if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) { $found_name = substr($linestr, $offset, $len); $offset += $len; - $in_declare++; } } if ($flags & DECLARE_PROTO) { @@ -230,11 +235,9 @@ sub linestr_callback_rv2cv { substr($linestr, $offset, $length) = $replace; set_linestr($linestr); $offset += $length; - $in_declare++; } } my @args = ($pack, $name, $pack, $found_name, $found_proto); - set_in_declare($in_declare); $offset += toke_skipspace($offset); my $linestr = get_linestr(); if (substr($linestr, $offset, 1) eq '{') { @@ -267,8 +270,19 @@ sub linestr_callback_const { sub linestr_callback { my $type = shift; - my $meth = "linestr_callback_${type}"; - __PACKAGE__->can($meth)->(@_); + my $name = $_[0]; + my $pack = get_curstash_name(); + my $handlers = $declarator_handlers{$pack}{$name}; + if (ref $handlers eq 'CODE') { + my $meth = "linestr_callback_${type}"; + __PACKAGE__->can($meth)->(@_); + } elsif (ref $handlers eq 'HASH') { + if ($handlers->{$type}) { + $handlers->{$type}->(@_); + } + } else { + die "PANIC: unknown thing in handlers for $pack $name: $handlers"; + } } =head1 NAME