diff options
Diffstat (limited to 'ext')
| -rw-r--r-- | ext/re/re.pm | 35 | ||||
| -rw-r--r-- | ext/re/re.xs | 106 | ||||
| -rw-r--r-- | ext/re/t/lexical_debug.pl | 25 | ||||
| -rw-r--r-- | ext/re/t/lexical_debug.t | 30 | ||||
| -rw-r--r-- | ext/re/t/re.t | 7 |
5 files changed, 95 insertions, 108 deletions
diff --git a/ext/re/re.pm b/ext/re/re.pm index ee262c6141..9fab039c04 100644 --- a/ext/re/re.pm +++ b/ext/re/re.pm @@ -215,6 +215,10 @@ sub setcolor { $colors =~ s/\0//g; $ENV{PERL_RE_COLORS} = $colors; }; + if ($@) { + $ENV{PERL_RE_COLORS}||=qq'\t\t> <\t> <\t\t' + } + } my %flags = ( @@ -241,31 +245,34 @@ $flags{More} = $flags{MORE} = $flags{All} | $flags{TRIE_MORE} | $flags{STATE}; $flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE}; $flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIE_COMPILE}; -my $installed = 0; - -sub _load_unload { - my $on = shift; +my $installed =eval { require XSLoader; XSLoader::load('re'); - install($on); + install(); +}; + +sub _load_unload { + my ($on)= @_; + if ($on) { + die "'re' not installed!?" unless $installed; + #warn "installed: $installed\n"; + install(); # allow for changes in colors + $^H{regcomp}= $installed; + } else { + delete $^H{regcomp}; + } } sub bits { my $on = shift; my $bits = 0; unless (@_) { - require Carp; - Carp::carp("Useless use of \"re\" pragma"); + return; } foreach my $idx (0..$#_){ my $s=$_[$idx]; if ($s eq 'Debug' or $s eq 'Debugcolor') { - if ($s eq 'Debugcolor') { - setcolor(); - } else { - # $ENV{PERL_RE_COLORS}||=qq'\t\t> <\t> <\t\t' - } - + setcolor() if $s =~/color/i; ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS}; for my $idx ($idx+1..$#_) { if ($flags{$_[$idx]}) { @@ -283,7 +290,7 @@ sub bits { _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS}); last; } elsif ($s eq 'debug' or $s eq 'debugcolor') { - setcolor() if $s eq 'debugcolor'; + setcolor() if $s =~/color/i; _load_unload($on); } elsif (exists $bitmask{$s}) { $bits |= $bitmask{$s}; diff --git a/ext/re/re.xs b/ext/re/re.xs index 3433a0fd7e..933296b10d 100644 --- a/ext/re/re.xs +++ b/ext/re/re.xs @@ -7,6 +7,7 @@ #include "perl.h" #include "XSUB.h" + START_EXTERN_C extern regexp* my_regcomp (pTHX_ char* exp, char* xend, PMOP* pm); @@ -19,104 +20,29 @@ extern char* my_re_intuit_start (pTHX_ regexp *prog, SV *sv, char *strpos, struct re_scream_pos_data_s *data); extern SV* my_re_intuit_string (pTHX_ regexp *prog); -extern regexp* my_regdupe (pTHX_ regexp *r, CLONE_PARAMS *param); - - -END_EXTERN_C - -/* engine details need to be paired - non debugging, debuggin */ -#define NEEDS_DEBUGGING 0x01 -struct regexp_engine { - regexp* (*regcomp) (pTHX_ char* exp, char* xend, PMOP* pm); - I32 (*regexec) (pTHX_ regexp* prog, char* stringarg, char* strend, - char* strbeg, I32 minend, SV* screamer, - void* data, U32 flags); - char* (*re_intuit_start) (pTHX_ regexp *prog, SV *sv, char *strpos, - char *strend, U32 flags, - struct re_scream_pos_data_s *data); - SV* (*re_intuit_string) (pTHX_ regexp *prog); - void (*regfree) (pTHX_ struct regexp* r); #if defined(USE_ITHREADS) - regexp* (*regdupe) (pTHX_ regexp *r, CLONE_PARAMS *param); +extern regexp* my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param); #endif -}; -struct regexp_engine engines[] = { - { Perl_pregcomp, Perl_regexec_flags, Perl_re_intuit_start, - Perl_re_intuit_string, Perl_pregfree +const struct regexp_engine my_reg_engine = { + my_regcomp, + my_regexec, + my_re_intuit_start, + my_re_intuit_string, + my_regfree, #if defined(USE_ITHREADS) - , Perl_regdupe + my_regdupe #endif - }, - { my_regcomp, my_regexec, my_re_intuit_start, my_re_intuit_string, - my_regfree -#if defined(USE_ITHREADS) - , my_regdupe -#endif - } }; -#define MY_CXT_KEY "re::_guts" XS_VERSION - -typedef struct { - int x_oldflag; /* debug flag */ - unsigned int x_state; -} my_cxt_t; - -START_MY_CXT - -#define oldflag (MY_CXT.x_oldflag) - -static void -install(pTHX_ unsigned int new_state) -{ - dMY_CXT; - const unsigned int states - = sizeof(engines) / sizeof(struct regexp_engine) -1; - if(new_state == MY_CXT.x_state) - return; - - if (new_state > states) { - Perl_croak(aTHX_ "panic: re::install state %u is illegal - max is %u", - new_state, states); - } - - PL_regexecp = engines[new_state].regexec; - PL_regcompp = engines[new_state].regcomp; - PL_regint_start = engines[new_state].re_intuit_start; - PL_regint_string = engines[new_state].re_intuit_string; - PL_regfree = engines[new_state].regfree; -#if defined(USE_ITHREADS) - PL_regdupe = engines[new_state].regdupe; -#endif - - if (new_state & NEEDS_DEBUGGING) { - PL_colorset = 0; /* Allow reinspection of ENV. */ - if (!(MY_CXT.x_state & NEEDS_DEBUGGING)) { - /* Debugging is turned on for the first time. */ - oldflag = PL_debug & DEBUG_r_FLAG; - PL_debug |= DEBUG_r_FLAG; - } - } else { - if (!(MY_CXT.x_state & NEEDS_DEBUGGING)) { - if (!oldflag) - PL_debug &= ~DEBUG_r_FLAG; - } - } - - MY_CXT.x_state = new_state; -} +END_EXTERN_C MODULE = re PACKAGE = re -BOOT: -{ - MY_CXT_INIT; -} - - void -install(new_state) - unsigned int new_state; - CODE: - install(aTHX_ new_state); +install() + PPCODE: + PL_colorset = 0; /* Allow reinspection of ENV. */ + /* PL_debug |= DEBUG_r_FLAG; */ + XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine)))); + diff --git a/ext/re/t/lexical_debug.pl b/ext/re/t/lexical_debug.pl new file mode 100644 index 0000000000..c8b7c5bc67 --- /dev/null +++ b/ext/re/t/lexical_debug.pl @@ -0,0 +1,25 @@ +use re 'debug'; + +$_ = 'foo bar baz bop fip fop'; + +/foo/ and $count++; + +{ + no re 'debug'; + /bar/ and $count++; + { + use re 'debug'; + /baz/ and $count++; + } + /bop/ and $count++; +} + +/fip/ and $count++; + +no re 'debug'; + +/fop/ and $count++; + +print "Count=$count\n"; + + diff --git a/ext/re/t/lexical_debug.t b/ext/re/t/lexical_debug.t new file mode 100644 index 0000000000..affa7c50fc --- /dev/null +++ b/ext/re/t/lexical_debug.t @@ -0,0 +1,30 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; + if (($Config::Config{'extensions'} !~ /\bre\b/) ){ + print "1..0 # Skip -- Perl configured without re module\n"; + exit 0; + } +} + +use strict; +require "./test.pl"; +my $out = runperl(progfile => "../ext/re/t/lexical_debug.pl", stderr => 1 ); + +print "1..7\n"; + +# Each pattern will produce an EXACT node with a specific string in +# it, so we will look for that. We can't just look for the string +# alone as the string being matched against contains all of them. + +ok( $out =~ /EXACT <foo>/, "Expect 'foo'"); +ok( $out !~ /EXACT <bar>/, "No 'bar'"); +ok( $out =~ /EXACT <baz>/, "Expect 'baz'"); +ok( $out !~ /EXACT <bop>/, "No 'bop'"); +ok( $out =~ /EXACT <fip>/, "Expect 'fip'"); +ok( $out !~ /EXACT <fop>/, "No 'baz'"); +ok( $out =~ /Count=6\n/,"Count is 6"); + diff --git a/ext/re/t/re.t b/ext/re/t/re.t index 5f09966d81..204092f028 100644 --- a/ext/re/t/re.t +++ b/ext/re/t/re.t @@ -12,7 +12,7 @@ BEGIN { use strict; -use Test::More tests => 14; +use Test::More tests => 13; require_ok( 're' ); # setcolor @@ -31,8 +31,8 @@ my $warn; local $SIG{__WARN__} = sub { $warn = shift; }; -eval { re::bits(1) }; -like( $warn, qr/Useless use/, 'bits() should warn with no args' ); +#eval { re::bits(1) }; +#like( $warn, qr/Useless use/, 'bits() should warn with no args' ); delete $ENV{PERL_RE_COLORS}; re::bits(0, 'debug'); @@ -65,7 +65,6 @@ my $ok='foo'=~/$reg/; eval"no re Debug=>'ALL'"; ok( $ok, 'No segv!' ); - package Term::Cap; sub Tgetent { |