ext/re/re.xs re extension external subroutines
ext/re/t/lexical_debug.pl generate debug output for lexical re 'debug'
ext/re/t/lexical_debug.t test that lexical re 'debug' works
+ext/re/t/qr.t test that qr// is a Regexp
ext/re/t/re_funcs.t see if exportable funcs from re.pm work
ext/re/t/regop.pl generate debug output for various patterns
ext/re/t/regop.t test RE optimizations by scraping debug output
t/op/ref.t See if refs and objects work
t/op/regexp_email.t See if regex recursion works by parsing email addresses
t/op/regexp_namedcapture.t Make sure glob assignment doesn't break named capture
+t/op/regexp_nc_tie.t Test the tied methods of Tie::Hash::NamedCapture
t/op/regexp_noamp.t See if regular expressions work with optimizations
t/op/regexp_notrie.t See if regular expressions work without trie optimisation
t/op/regexp_pmod.t See if regexp /p modifier works as expected
|NN SV* screamer|NULLOK void* data|U32 flags
ApR |regnode*|regnext |NN regnode* p
-EXp |SV*|reg_named_buff_fetch |NN REGEXP * const rx|NN SV * const key|const U32 flags
+EXp |SV*|reg_named_buff |NN REGEXP * const rx|NULLOK SV * const key \
+ |NULLOK SV * const value|const U32 flags
+EXp |SV*|reg_named_buff_iter |NN REGEXP * const rx|NULLOK const SV * const lastkey \
+ |const U32 flags
+Ap |SV*|reg_named_buff_fetch |NN REGEXP * const rx|NN SV * const namesv|const U32 flags
+Ap |bool|reg_named_buff_exists |NN REGEXP * const rx|NN SV * const key|const U32 flags
+Ap |SV*|reg_named_buff_firstkey |NN REGEXP * const rx|const U32 flags
+Ap |SV*|reg_named_buff_nextkey |NN REGEXP * const rx|const U32 flags
+Ap |SV*|reg_named_buff_scalar |NN REGEXP * const rx|const U32 flags
+Ap |SV*|reg_named_buff_all |NN REGEXP * const rx|const U32 flags
EXp |void|reg_numbered_buff_fetch|NN REGEXP * const rx|const I32 paren|NULLOK SV * const sv
EXp |void|reg_numbered_buff_store|NN REGEXP * const rx|const I32 paren|NULLOK SV const * const value
#define regexec_flags Perl_regexec_flags
#define regnext Perl_regnext
#if defined(PERL_CORE) || defined(PERL_EXT)
-#define reg_named_buff_fetch Perl_reg_named_buff_fetch
+#define reg_named_buff Perl_reg_named_buff
+#define reg_named_buff_iter Perl_reg_named_buff_iter
#endif
+#define reg_named_buff_fetch Perl_reg_named_buff_fetch
+#define reg_named_buff_exists Perl_reg_named_buff_exists
+#define reg_named_buff_firstkey Perl_reg_named_buff_firstkey
+#define reg_named_buff_nextkey Perl_reg_named_buff_nextkey
+#define reg_named_buff_scalar Perl_reg_named_buff_scalar
+#define reg_named_buff_all Perl_reg_named_buff_all
#if defined(PERL_CORE) || defined(PERL_EXT)
#define reg_numbered_buff_fetch Perl_reg_numbered_buff_fetch
#define reg_numbered_buff_store Perl_reg_numbered_buff_store
#define regexec_flags(a,b,c,d,e,f,g,h) Perl_regexec_flags(aTHX_ a,b,c,d,e,f,g,h)
#define regnext(a) Perl_regnext(aTHX_ a)
#if defined(PERL_CORE) || defined(PERL_EXT)
-#define reg_named_buff_fetch(a,b,c) Perl_reg_named_buff_fetch(aTHX_ a,b,c)
+#define reg_named_buff(a,b,c,d) Perl_reg_named_buff(aTHX_ a,b,c,d)
+#define reg_named_buff_iter(a,b,c) Perl_reg_named_buff_iter(aTHX_ a,b,c)
#endif
+#define reg_named_buff_fetch(a,b,c) Perl_reg_named_buff_fetch(aTHX_ a,b,c)
+#define reg_named_buff_exists(a,b,c) Perl_reg_named_buff_exists(aTHX_ a,b,c)
+#define reg_named_buff_firstkey(a,b) Perl_reg_named_buff_firstkey(aTHX_ a,b)
+#define reg_named_buff_nextkey(a,b) Perl_reg_named_buff_nextkey(aTHX_ a,b)
+#define reg_named_buff_scalar(a,b) Perl_reg_named_buff_scalar(aTHX_ a,b)
+#define reg_named_buff_all(a,b) Perl_reg_named_buff_all(aTHX_ a,b)
#if defined(PERL_CORE) || defined(PERL_EXT)
#define reg_numbered_buff_fetch(a,b,c) Perl_reg_numbered_buff_fetch(aTHX_ a,b,c)
#define reg_numbered_buff_store(a,b,c) Perl_reg_numbered_buff_store(aTHX_ a,b,c)
use Carp;
use Test::More tests => ( # per-pkg tests (function ct + require_ok)
40 + 16 # Data::Dumper, Digest::MD5
- + 517 + 262 # B::Deparse, B
+ + 517 + 276 # B::Deparse, B
+ 595 + 190 # POSIX, IO::Socket
- - 6); # fudge
+ - 20); # fudge
require_ok("B::Concise");
our $VERSION = "0.08";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(is_regexp regexp_pattern regmust
- regname regnames
- regnames_count regnames_iterinit regnames_iternext);
+ regname regnames regnames_count);
our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
# *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
match. If $all is true, then it returns all names defined, if not it returns
only names which were involved in the match.
-=item regnames_iterinit()
-
-Initializes the internal hash iterator associated to the last successful
-matches named capture buffers.
-
-=item regnames_iternext($all)
-
-Gets the next key from the named capture buffer hash associated with the
-last successful match. If $all is true returns the keys of all of the
-distinct named buffers in the pattern, if not returns only those names
-used in the last successful match.
-
=item regnames_count()
Returns the number of distinct names defined in the pattern used
extern I32 my_reg_numbered_buff_length(pTHX_ REGEXP * const rx,
const SV * const sv, const I32 paren);
-extern SV* my_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const key,
- const U32 flags);
+extern SV* my_reg_named_buff(pTHX_ REGEXP * const, SV * const, SV * const,
+ const U32);
+extern SV* my_reg_named_buff_iter(pTHX_ REGEXP * const rx,
+ const SV * const lastkey, const U32 flags);
extern SV* my_reg_qr_package(pTHX_ REGEXP * const rx);
#if defined(USE_ITHREADS)
my_reg_numbered_buff_fetch,
my_reg_numbered_buff_store,
my_reg_numbered_buff_length,
- my_reg_named_buff_fetch,
+ my_reg_named_buff,
+ my_reg_named_buff_iter,
my_reg_qr_package,
#if defined(USE_ITHREADS)
my_regdupe
#define Perl_reg_numbered_buff_fetch my_reg_numbered_buff_fetch
#define Perl_reg_numbered_buff_store my_reg_numbered_buff_store
#define Perl_reg_numbered_buff_length my_reg_numbered_buff_length
-#define Perl_reg_named_buff_fetch my_reg_named_buff_fetch
+#define Perl_reg_named_buff my_reg_named_buff
+#define Perl_reg_named_buff_iter my_reg_named_buff_iter
#define Perl_reg_qr_package my_reg_qr_package
#define PERL_NO_GET_CONTEXT
--- /dev/null
+#!./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 Test::More tests => 1;
+use re 'Debug';
+isa_ok( qr//, "Regexp" );
use Test::More; # test count at bottom of file
use re qw(is_regexp regexp_pattern regmust
- regname regnames regnames_count
- regnames_iterinit regnames_iternext);
+ regname regnames regnames_count);
{
my $qr=qr/foo/pi;
ok(is_regexp($qr),'is_regexp($qr)');
is($floating,undef,"Regmust anchored - ref");
}
-
if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
my @names = sort +regnames();
is("@names","A B","regnames");
+ my @names = sort +regnames(0);
+ is("@names","A B","regnames");
+ my $names = regnames();
+ is($names, "B", "regnames in scalar context");
@names = sort +regnames(1);
is("@names","A B C","regnames");
is(join("", @{regname("A",1)}),"13");
is(join("", @{regname("B",1)}),"24");
{
if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) {
- regnames_iterinit();
- my @res;
- while (defined(my $key=regnames_iternext)) {
- push @res,$key;
- }
- @res=sort @res;
- is("@res","bar foo");
is(regnames_count(),2);
} else {
ok(0); ok(0);
is(regnames_count(),3);
}
# New tests above this line, don't forget to update the test count below!
-use Test::More tests => 19;
+use Test::More tests => 20;
# No tests here!
Perl_re_intuit_string
Perl_regexec_flags
Perl_regnext
+Perl_reg_named_buff
+Perl_reg_named_buff_iter
Perl_reg_named_buff_fetch
+Perl_reg_named_buff_exists
+Perl_reg_named_buff_firstkey
+Perl_reg_named_buff_nextkey
+Perl_reg_named_buff_scalar
+Perl_reg_named_buff_all
Perl_reg_numbered_buff_fetch
Perl_reg_numbered_buff_store
Perl_reg_numbered_buff_length
if (*name == '!')
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
else if (*name == '-' || *name == '+')
- require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
+ require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
}
}
return gv;
SvREADONLY_on(av);
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
+ require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
break;
}
package Tie::Hash::NamedCapture;
-use strict;
-use warnings;
+our $VERSION = "0.06";
-our $VERSION = "0.05";
+# The real meat implemented in XS in universal.c in the core, but this
+# method was left behind because gv.c expects a Purl-Perl method in
+# this package when it loads the tie magic for %+ and %-
-sub TIEHASH {
- my $classname = shift;
- my %opts = @_;
-
- my $self = bless { all => $opts{all} }, $classname;
- return $self;
-}
-
-sub FETCH {
- return re::regname($_[1],$_[0]->{all});
-}
-
-sub STORE {
- require Carp;
- Carp::croak("STORE forbidden: hashes tied to ",__PACKAGE__," are read-only.");
-}
-
-sub FIRSTKEY {
- re::regnames_iterinit();
- return $_[0]->NEXTKEY;
-}
+my ($one, $all) = Tie::Hash::NamedCapture::flags();
-sub NEXTKEY {
- return re::regnames_iternext($_[0]->{all});
-}
-
-sub EXISTS {
- return defined re::regname( $_[1], $_[0]->{all});
-}
-
-sub DELETE {
- require Carp;
- Carp::croak("DELETE forbidden: hashes tied to ",__PACKAGE__," are read-only");
-}
-
-sub CLEAR {
- require Carp;
- Carp::croak("CLEAR forbidden: hashes tied to ",__PACKAGE__," are read-only");
-}
-
-sub SCALAR {
- return scalar re::regnames($_[0]->{all});
+sub TIEHASH {
+ my ($pkg, %arg) = @_;
+ my $flag = $arg{all} ? $all : $one;
+ bless \$flag => $pkg;
}
tie %+, __PACKAGE__;
=head1 SEE ALSO
-L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">, L<perlvar/"%-">.
+L<perlreapi>, L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">,
+L<perlvar/"%-">.
=cut
}
case '`':
do_prematch:
- paren = -2;
+ paren = RXf_PREMATCH;
goto maybegetparen;
case '\'':
do_postmatch:
- paren = -1;
+ paren = RXf_POSTMATCH;
goto maybegetparen;
case '&':
do_match:
- paren = 0;
+ paren = RXf_MATCH;
goto maybegetparen;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
goto do_match;
case '`': /* ${^PREMATCH} caught below */
do_prematch:
- paren = -2;
+ paren = RXf_PREMATCH;
goto setparen;
case '\'': /* ${^POSTMATCH} caught below */
do_postmatch:
- paren = -1;
+ paren = RXf_POSTMATCH;
goto setparen;
case '&':
do_match:
- paren = 0;
+ paren = RXf_MATCH;
goto setparen;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
#define CALLREG_NUMBUF_LENGTH(rx,sv,paren) \
CALL_FPTR((rx)->engine->numbered_buff_LENGTH)(aTHX_ (rx),(sv),(paren))
-#define CALLREG_NAMEDBUF_FETCH(rx,name,flags) \
- CALL_FPTR((rx)->engine->named_buff_FETCH)(aTHX_ (rx),(name),(flags))
+#define CALLREG_NAMED_BUFF_FETCH(rx, key, flags) \
+ CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), (key), NULL, ((flags) | RXf_HASH_FETCH))
+
+#define CALLREG_NAMED_BUFF_STORE(rx, key, value, flags) \
+ CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), (key), (value), ((flags) | RXf_HASH_STORE))
+
+#define CALLREG_NAMED_BUFF_DELETE(rx, key, flags) \
+ CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx),(key), NULL, ((flags) | RXf_HASH_DELETE))
+
+#define CALLREG_NAMED_BUFF_CLEAR(rx, flags) \
+ CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), NULL, NULL, ((flags) | RXf_HASH_CLEAR))
+
+#define CALLREG_NAMED_BUFF_EXISTS(rx, key, flags) \
+ CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), (key), NULL, ((flags) | RXf_HASH_EXISTS))
+
+#define CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags) \
+ CALL_FPTR((rx)->engine->named_buff_iter)(aTHX_ (rx), NULL, ((flags) | RXf_HASH_FIRSTKEY))
+
+#define CALLREG_NAMED_BUFF_NEXTKEY(rx, lastkey, flags) \
+ CALL_FPTR((rx)->engine->named_buff_iter)(aTHX_ (rx), (lastkey), ((flags) | RXf_HASH_NEXTKEY))
+
+#define CALLREG_NAMED_BUFF_SCALAR(rx, flags) \
+ CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), NULL, NULL, ((flags) | RXf_HASH_SCALAR))
+
+#define CALLREG_NAMED_BUFF_COUNT(rx) \
+ CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), NULL, NULL, RXf_HASH_REGNAMES_COUNT)
+
+#define CALLREG_NAMED_BUFF_ALL(rx, flags) \
+ CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), NULL, NULL, flags)
#define CALLREG_PACKAGE(rx) \
CALL_FPTR((rx)->engine->qr_package)(aTHX_ (rx))
SV const * const value);
I32 (*numbered_buff_LENGTH) (pTHX_ REGEXP * const rx, const SV * const sv,
const I32 paren);
- SV* (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const sv,
- const U32 flags);
+ SV* (*named_buff) (pTHX_ REGEXP * const rx, SV * const key,
+ SV * const value, U32 flags);
+ SV* (*named_buff_iter) (pTHX_ REGEXP * const rx, const SV * const lastkey,
+ const U32 flags);
SV* (*qr_package)(pTHX_ REGEXP * const rx);
#ifdef USE_ITHREADS
void* (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
regexp structure. This is only responsible for freeing private data;
perl will handle releasing anything else contained in the regexp structure.
-=head2 numbered_buff_FETCH
+=head2 Numbered capture callbacks
- void numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren,
- SV * const sv);
-
-Called to get the value of C<$`>, C<$'>, C<$&> (and their named
-equivalents, see L<perlvar>) and the numbered capture buffers (C<$1>,
-C<$2>, ...).
+Called to get/set the value of C<$`>, C<$'>, C<$&> and their named
+equivalents, ${^PREMATCH}, ${^POSTMATCH} and $^{MATCH}, as well as the
+numbered capture buffers (C<$1>, C<$2>, ...).
The C<paren> paramater will be C<-2> for C<$`>, C<-1> for C<$'>, C<0>
for C<$&>, C<1> for C<$1> and so forth.
-C<sv> should be set to the scalar to return, the scalar is passed as
-an argument rather than being returned from the function because when
-it's called perl already has a scalar to store the value, creating
-another one would be redundant. The scalar can be set with
-C<sv_setsv>, C<sv_setpvn> and friends, see L<perlapi>.
+The names have been chosen by analogy with L<Tie::Scalar> methods
+names with an additional B<LENGTH> callback for efficiency. However
+named capture variables are currently not tied internally but
+implemented via magic.
+
+=head3 numbered_buff_FETCH
+
+ void numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren,
+ SV * const sv);
+
+Fetch a specified numbered capture. C<sv> should be set to the scalar
+to return, the scalar is passed as an argument rather than being
+returned from the function because when it's called perl already has a
+scalar to store the value, creating another one would be
+redundant. The scalar can be set with C<sv_setsv>, C<sv_setpvn> and
+friends, see L<perlapi>.
This callback is where perl untaints its own capture variables under
taint mode (see L<perlsec>). See the C<Perl_reg_numbered_buff_get>
function in F<regcomp.c> for how to untaint capture variables if
that's something you'd like your engine to do as well.
-=head2 numbered_buff_STORE
+=head3 numbered_buff_STORE
void (*numbered_buff_STORE) (pTHX_ REGEXP * const rx, const I32 paren,
SV const * const value);
-Called to set the value of a numbered capture variable. C<paren> is
-the paren number (see the L<mapping|/numbered_buff_FETCH> above) and
-C<value> is the scalar that is to be used as the new value. It's up to
-the engine to make sure this is used as the new value (or reject it).
+Set the value of a numbered capture variable. C<value> is the scalar
+that is to be used as the new value. It's up to the engine to make
+sure this is used as the new value (or reject it).
Example:
Because C<$sv> is C<undef> when the C<y///> operator is applied to it
the transliteration won't actually execute and the program won't
-C<die>. This is different to how 5.8 behaved since the capture
-variables were READONLY variables then, now they'll just die on
-assignment in the default engine.
+C<die>. This is different to how 5.8 and earlier versions behaved
+since the capture variables were READONLY variables then, now they'll
+just die when assigned to in the default engine.
-=head2 numbered_buff_LENGTH
+=head3 numbered_buff_LENGTH
I32 numbered_buff_LENGTH (pTHX_ REGEXP * const rx, const SV * const sv,
const I32 paren);
Get the C<length> of a capture variable. There's a special callback
for this so that perl doesn't have to do a FETCH and run C<length> on
-the result, since the length is (in perl's case) known from a memory
-offset this is much more efficient:
+the result, since the length is (in perl's case) known from an offset
+stored in C<<rx->offs> this is much more efficient:
I32 s1 = rx->offs[paren].start;
I32 s2 = rx->offs[paren].end;
C<Perl_reg_numbered_buff_length> does with
L<is_utf8_string_loclen|perlapi/is_utf8_string_loclen>.
-=head2 named_buff_FETCH
+=head2 Named capture callbacks
+
+Called to get/set the value of C<%+> and C<%-> as well as by some
+utility functions in L<re>.
+
+There are two callbacks, C<named_buff> is called in all the cases the
+FETCH, STORE, DELETE, CLEAR, EXISTS and SCALAR L<Tie::Hash> callbacks
+would be on changes to C<%+> and C<%-> and C<named_buff_iter> in the
+same cases as FIRSTKEY and NEXTKEY.
+
+The C<flags> parameter can be used to determine which of these
+operations the callbacks should respond to, the following flags are
+currently defined:
+
+Which L<Tie::Hash> operation is being performed from the Perl level on
+C<%+> or C<%+>, if any:
+
+ RXf_HASH_FETCH
+ RXf_HASH_STORE
+ RXf_HASH_DELETE
+ RXf_HASH_CLEAR
+ RXf_HASH_EXISTS
+ RXf_HASH_SCALAR
+ RXf_HASH_FIRSTKEY
+ RXf_HASH_NEXTKEY
+
+Whether C<%+> or C<%-> is being operated on, if any.
- SV* named_buff_FETCH(pTHX_ REGEXP * const rx, SV * const key,
- const U32 flags);
+ RXf_HASH_ONE /* %+ */
+ RXf_HASH_ALL /* %- */
-Called to get the value of key in the C<%+> and C<%-> hashes, C<key>
-is the hash key being requested and if C<flags & 1> is true C<%-> is
-being requested (and C<%+> if it's not).
+Whether this is being called as C<re::regname>, C<re::regnames> or
+C<C<re::regnames_count>, if any. The first two will be combined with
+C<RXf_HASH_ONE> or C<RXf_HASH_ALL>.
+
+ RXf_HASH_REGNAME
+ RXf_HASH_REGNAMES
+ RXf_HASH_REGNAMES_COUNT
+
+Internally C<%+> and C<%-> are implemented with a real tied interface
+via L<Tie::Hash::NamedCapture>. The methods in that package will call
+back into these functions. However the usage of
+L<Tie::Hash::NamedCapture> for this purpose might change in future
+releases. For instance this might be implemented by magic instead
+(would need an extension to mgvtbl).
+
+=head3 named_buff
+
+ SV* (*named_buff) (pTHX_ REGEXP * const rx, SV * const key,
+ SV * const value, U32 flags);
+
+=head3 named_buff_iter
+
+ SV* (*named_buff_iter) (pTHX_ REGEXP * const rx, const SV * const lastkey,
+ const U32 flags);
=head2 qr_package
name for identification regardless of whether they implement methods
on the object.
-A callback implementation might be:
+The package this method returns should also have the internal
+C<Regexp> package in its C<@ISA>. C<qr//->isa("Regexp")> should always
+be true regardless of what engine is being used.
+
+Example implementation might be:
SV*
- Example_reg_qr_package(pTHX_ REGEXP * const rx)
+ Example_qr_package(pTHX_ REGEXP * const rx)
{
PERL_UNUSED_ARG(rx);
return newSVpvs("re::engine::Example");
SvTYPE(sv) == SVt_PVMG &&
(mg = mg_find(sv, PERL_MAGIC_qr))) /* assignment deliberate */
{
- re = (REGEXP *)mg->mg_obj;
+ re = (REGEXP *)mg->mg_obj;
}
-Or use the (CURRENTLY UNDOCUMENETED!) C<Perl_get_re_arg> function:
-
- void meth(SV * rv)
- PPCODE:
- const REGEXP * const re = (REGEXP *)Perl_get_re_arg( aTHX_ rv, 0, NULL );
-
=head2 dupe
void* dupe(pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
=head2 C<extflags>
-This will be used by perl to see what flags the regexp was compiled with, this
-will normally be set to the value of the flags parameter on L</comp>.
+This will be used by perl to see what flags the regexp was compiled
+with, this will normally be set to the value of the flags parameter by
+the L<comp|/comp> callback.
=head2 C<minlen> C<minlenret>
=head2 C<substrs>
-TODO: document
+Substring data about strings that must appear in the final match. This
+is currently only used internally by perl's engine for but might be
+used in the future for all engines for optimisations like C<minlen>.
=head2 C<nparens>, C<lasparen>, and C<lastcloseparen>
=head2 C<intflags>
The engine's private copy of the flags the pattern was compiled with. Usually
-this is the same as C<extflags> unless the engine chose to modify one of them
+this is the same as C<extflags> unless the engine chose to modify one of them.
=head2 C<pprivate>
=head2 C<precomp> C<prelen>
-Used for debugging purposes. C<precomp> holds a copy of the pattern
-that was compiled and C<prelen> its length.
+Used for optimisations. C<precomp> holds a copy of the pattern that
+was compiled and C<prelen> its length. When a new pattern is to be
+compiled (such as inside a loop) the internal C<regcomp> operator
+checks whether the last compiled C<REGEXP>'s C<precomp> and C<prelen>
+are equivalent to the new one, and if so uses the old pattern instead
+of compiling a new one.
+
+The relevant snippet from C<Perl_pp_regcomp>:
+
+ if (!re || !re->precomp || re->prelen != (I32)len ||
+ memNE(re->precomp, t, len))
+ /* Compile a new pattern */
=head2 C<paren_names>
note that this will create invalid patterns in cases such as:
my $x = qr/a|b/; # "a|b"
- my $y = qr/c/; # "c"
+ my $y = qr/c/i; # "c"
my $z = qr/$x$y/; # "a|bc"
-There's no solution for such problems other than making the custom engine
-understand some for of inline modifiers.
+There's no solution for this problem other than making the custom
+engine understand a construct like C<(?:)>.
The C<Perl_reg_stringify> in F<regcomp.c> does the stringification work.
__attribute__nonnull__(pTHX_1);
-PERL_CALLCONV SV* Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
+PERL_CALLCONV SV* Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV SV* Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV SV* Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
+PERL_CALLCONV bool Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+
+PERL_CALLCONV SV* Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV SV* Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV SV* Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV SV* Perl_reg_named_buff_all(pTHX_ REGEXP * const rx, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+
PERL_CALLCONV void Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
__attribute__nonnull__(pTHX_1);
SV*
+Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
+ const U32 flags)
+{
+ PERL_UNUSED_ARG(value);
+
+ if (flags & RXf_HASH_FETCH) {
+ return reg_named_buff_fetch(rx, key, flags);
+ } else if (flags & (RXf_HASH_STORE | RXf_HASH_DELETE | RXf_HASH_CLEAR)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ return NULL;
+ } else if (flags & RXf_HASH_EXISTS) {
+ return reg_named_buff_exists(rx, key, flags)
+ ? &PL_sv_yes
+ : &PL_sv_no;
+ } else if (flags & RXf_HASH_REGNAMES) {
+ return reg_named_buff_all(rx, flags);
+ } else if (flags & (RXf_HASH_SCALAR | RXf_HASH_REGNAMES_COUNT)) {
+ return reg_named_buff_scalar(rx, flags);
+ } else {
+ Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
+ return NULL;
+ }
+}
+
+SV*
+Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
+ const U32 flags)
+{
+ PERL_UNUSED_ARG(lastkey);
+
+ if (flags & RXf_HASH_FIRSTKEY)
+ return reg_named_buff_firstkey(rx, flags);
+ else if (flags & RXf_HASH_NEXTKEY)
+ return reg_named_buff_nextkey(rx, flags);
+ else {
+ Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
+ return NULL;
+ }
+}
+
+SV*
Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags)
{
AV *retarray = NULL;
SV *ret;
- if (flags & 1)
+ if (flags & RXf_HASH_ALL)
retarray=newAV();
if (rx && rx->paren_names) {
SV* sv_dat=HeVAL(he_str);
I32 *nums=(I32*)SvPVX(sv_dat);
for ( i=0; i<SvIVX(sv_dat); i++ ) {
- if ((I32)(rx->nparens) >= nums[i]
- && rx->offs[nums[i]].start != -1
- && rx->offs[nums[i]].end != -1)
+ if ((I32)(rx->nparens) >= nums[i]
+ && rx->offs[nums[i]].start != -1
+ && rx->offs[nums[i]].end != -1)
{
ret = newSVpvs("");
CALLREG_NUMBUF_FETCH(rx,nums[i],ret);
}
}
if (retarray)
- return (SV*)retarray;
+ return newRV((SV*)retarray);
}
}
return NULL;
}
+bool
+Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key,
+ const U32 flags)
+{
+ if (rx && rx->paren_names) {
+ if (flags & RXf_HASH_ALL) {
+ return hv_exists_ent(rx->paren_names, key, 0);
+ } else {
+ if (CALLREG_NAMED_BUFF_FETCH(rx, key, flags)) {
+ return TRUE;
+ } else {
+ return FALSE;
+ }
+ }
+ } else {
+ return FALSE;
+ }
+}
+
+SV*
+Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags)
+{
+ (void)hv_iterinit(rx->paren_names);
+
+ return CALLREG_NAMED_BUFF_NEXTKEY(rx, NULL, flags & ~RXf_HASH_FIRSTKEY);
+}
+
+SV*
+Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, const U32 flags)
+{
+ if (rx && rx->paren_names) {
+ HV *hv = rx->paren_names;
+ HE *temphe;
+ while ( (temphe = hv_iternext_flags(hv,0)) ) {
+ IV i;
+ IV parno = 0;
+ SV* sv_dat = HeVAL(temphe);
+ I32 *nums = (I32*)SvPVX(sv_dat);
+ for ( i = 0; i < SvIVX(sv_dat); i++ ) {
+ if ((I32)(rx->lastcloseparen) >= nums[i] &&
+ rx->offs[nums[i]].start != -1 &&
+ rx->offs[nums[i]].end != -1)
+ {
+ parno = nums[i];
+ break;
+ }
+ }
+ if (parno || flags & RXf_HASH_ALL) {
+ STRLEN len;
+ char *pv = HePV(temphe, len);
+ return newSVpvn(pv,len);
+ }
+ }
+ }
+ return NULL;
+}
+
+SV*
+Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags)
+{
+ SV *ret;
+ AV *av;
+ I32 length;
+
+ if (rx && rx->paren_names) {
+ if (flags & (RXf_HASH_ALL | RXf_HASH_REGNAMES_COUNT)) {
+ return newSViv(HvTOTALKEYS(rx->paren_names));
+ } else if (flags & RXf_HASH_ONE) {
+ ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXf_HASH_REGNAMES));
+ av = (AV*)SvRV(ret);
+ length = av_len(av);
+ return newSViv(length + 1);
+ } else {
+ Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
+ return NULL;
+ }
+ }
+ return &PL_sv_undef;
+}
+
+SV*
+Perl_reg_named_buff_all(pTHX_ REGEXP * const rx, const U32 flags)
+{
+ AV *av = newAV();
+
+ if (rx && rx->paren_names) {
+ HV *hv= rx->paren_names;
+ HE *temphe;
+ (void)hv_iterinit(hv);
+ while ( (temphe = hv_iternext_flags(hv,0)) ) {
+ IV i;
+ IV parno = 0;
+ SV* sv_dat = HeVAL(temphe);
+ I32 *nums = (I32*)SvPVX(sv_dat);
+ for ( i = 0; i < SvIVX(sv_dat); i++ ) {
+ if ((I32)(rx->lastcloseparen) >= nums[i] &&
+ rx->offs[nums[i]].start != -1 &&
+ rx->offs[nums[i]].end != -1)
+ {
+ parno = nums[i];
+ break;
+ }
+ }
+ if (parno || flags & RXf_HASH_ALL) {
+ STRLEN len;
+ char *pv = HePV(temphe, len);
+ av_push(av, newSVpvn(pv,len));
+ }
+ }
+ }
+
+ return newRV((SV*)av);
+}
+
void
Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
{
return;
}
else
- if (paren == -2 && rx->offs[0].start != -1) {
+ if (paren == RXf_PREMATCH && rx->offs[0].start != -1) {
/* $` */
i = rx->offs[0].start;
s = rx->subbeg;
}
else
- if (paren == -1 && rx->offs[0].end != -1) {
+ if (paren == RXf_POSTMATCH && rx->offs[0].end != -1) {
/* $' */
s = rx->subbeg + rx->offs[0].end;
i = rx->sublen - rx->offs[0].end;
/* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
switch (paren) {
- case -2: /* $` */
+ /* $` / ${^PREMATCH} */
+ case RXf_PREMATCH:
if (rx->offs[0].start != -1) {
i = rx->offs[0].start;
if (i > 0) {
}
}
return 0;
- case -1: /* $' */
+ /* $' / ${^POSTMATCH} */
+ case RXf_POSTMATCH:
if (rx->offs[0].end != -1) {
i = rx->sublen - rx->offs[0].end;
if (i > 0) {
}
}
return 0;
- default: /* $&, $1, $2, ... */
+ /* $& / ${^MATCH}, $1, $2, ... */
+ default:
if (paren <= (I32)rx->nparens &&
(s1 = rx->offs[paren].start) != -1 &&
(t1 = rx->offs[paren].end) != -1)
Perl_reg_numbered_buff_fetch,
Perl_reg_numbered_buff_store,
Perl_reg_numbered_buff_length,
- Perl_reg_named_buff_fetch,
+ Perl_reg_named_buff,
+ Perl_reg_named_buff_iter,
Perl_reg_qr_package,
#if defined(USE_ITHREADS)
Perl_regdupe_internal
SV* (*checkstr) (pTHX_ REGEXP * const rx);
void (*free) (pTHX_ REGEXP * const rx);
void (*numbered_buff_FETCH) (pTHX_ REGEXP * const rx, const I32 paren,
- SV * const sv);
+ SV * const sv);
void (*numbered_buff_STORE) (pTHX_ REGEXP * const rx, const I32 paren,
SV const * const value);
I32 (*numbered_buff_LENGTH) (pTHX_ REGEXP * const rx, const SV * const sv,
const I32 paren);
- SV* (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const key,
- const U32 flags);
+ SV* (*named_buff) (pTHX_ REGEXP * const rx, SV * const key,
+ SV * const value, const U32 flags);
+ SV* (*named_buff_iter) (pTHX_ REGEXP * const rx, const SV * const lastkey,
+ const U32 flags);
SV* (*qr_package)(pTHX_ REGEXP * const rx);
#ifdef USE_ITHREADS
void* (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
#endif
} regexp_engine;
+/*
+ These are passed to the numbered capture variable callbacks as the
+ paren name. >= 1 is reserved for actual numbered captures, i.e. $1,
+ $2 etc.
+*/
+#define RXf_PREMATCH -2 /* $` / ${^PREMATCH} */
+#define RXf_POSTMATCH -1 /* $' / ${^POSTMATCH} */
+#define RXf_MATCH 0 /* $& / ${^MATCH} */
+
+/*
+ Flags that are passed to the named_buff and named_buff_iter
+ callbacks above. Those routines are called from universal.c via the
+ Tie::Hash::NamedCapture interface for %+ and %- and the re::
+ functions in the same file.
+*/
+
+/* The Tie::Hash::NamedCapture operation this is part of, if any */
+#define RXf_HASH_FETCH 0x0001
+#define RXf_HASH_STORE 0x0002
+#define RXf_HASH_DELETE 0x0004
+#define RXf_HASH_CLEAR 0x0008
+#define RXf_HASH_EXISTS 0x0010
+#define RXf_HASH_SCALAR 0x0020
+#define RXf_HASH_FIRSTKEY 0x0040
+#define RXf_HASH_NEXTKEY 0x0080
+
+/* Whether %+ or %- is being operated on */
+#define RXf_HASH_ONE 0x0100 /* %+ */
+#define RXf_HASH_ALL 0x0200 /* %- */
+
+/* Whether this is being called from a re:: function */
+#define RXf_HASH_REGNAME 0x0400
+#define RXf_HASH_REGNAMES 0x0800
+#define RXf_HASH_REGNAMES_COUNT 0x1000
+
/* Flags stored in regexp->extflags
* These are used by code external to the regexp engine
*
iseq(0+@a,3);
iseq(join('=', @a),"$esc$hyp=$hyp=$esc$esc");
}
+# test for keys in %+ and %-
+{
+ my $_ = "abcdef";
+ /(?<foo>a)|(?<foo>b)/;
+ iseq( (join ",", sort keys %+), "foo" );
+ iseq( (join ",", sort keys %-), "foo" );
+ iseq( (join ",", sort values %+), "a" );
+ iseq( (join ",", sort map "@$_", values %-), "a " );
+ /(?<bar>a)(?<bar>b)(?<quux>.)/;
+ iseq( (join ",", sort keys %+), "bar,quux" );
+ iseq( (join ",", sort keys %-), "bar,quux" );
+ iseq( (join ",", sort values %+), "a,c" ); # leftmost
+ iseq( (join ",", sort map "@$_", values %-), "a b,c" );
+ /(?<un>a)(?<deux>c)?/; # second buffer won't capture
+ iseq( (join ",", sort keys %+), "un" );
+ iseq( (join ",", sort keys %-), "deux,un" );
+ iseq( (join ",", sort values %+), "a" );
+ iseq( (join ",", sort map "@$_", values %-), ",a" );
+}
+
+# length() on captures, the numbered ones end up in Perl_magic_len
+{
+ my $_ = "aoeu \xe6var ook";
+ /^ \w+ \s (?<eek>\S+)/x;
+
+ iseq( length($`), 0, 'length $`' );
+ iseq( length($'), 4, q[length $'] );
+ iseq( length($&), 9, 'length $&' );
+ iseq( length($1), 4, 'length $1' );
+ iseq( length($+{eek}), 4, 'length $+{eek} == length $1' );
+}
+
+{
+ my $ok=-1;
+
+ $ok=exists($-{x}) ? 1 : 0
+ if 'bar'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$-{x} exists after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 0, 'scalar %+ == 0 after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "bar"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($+{x}) ? 1 : 0
+ if 'bar'=~/(?<x>foo)|bar/;
+ iseq($ok,0,'$+{x} not exists after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 0, 'scalar %+ == 0 after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "bar"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($-{x}) ? 1 : 0
+ if 'foo'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$-{x} exists after "foo"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 1, 'scalar %+ == 1 after "foo"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "foo"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($+{x}) ? 1 : 0
+ if 'foo'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$+{x} exists after "foo"=~/(?<x>foo)|bar/');
+}
+
+
# Test counter is at bottom of file. Put new tests above here.
#-------------------------------------------------------------------
# Keep the following tests last -- they may crash perl
iseq($_,"!Bang!1!Bang!2!Bang!3!Bang!");
}
-# test for keys in %+ and %-
-{
- my $_ = "abcdef";
- /(?<foo>a)|(?<foo>b)/;
- iseq( (join ",", sort keys %+), "foo" );
- iseq( (join ",", sort keys %-), "foo" );
- iseq( (join ",", sort values %+), "a" );
- iseq( (join ",", sort map "@$_", values %-), "a " );
- /(?<bar>a)(?<bar>b)(?<quux>.)/;
- iseq( (join ",", sort keys %+), "bar,quux" );
- iseq( (join ",", sort keys %-), "bar,quux" );
- iseq( (join ",", sort values %+), "a,c" ); # leftmost
- iseq( (join ",", sort map "@$_", values %-), "a b,c" );
- /(?<un>a)(?<deux>c)?/; # second buffer won't capture
- iseq( (join ",", sort keys %+), "un" );
- iseq( (join ",", sort keys %-), "deux,un" );
- iseq( (join ",", sort values %+), "a" );
- iseq( (join ",", sort map "@$_", values %-), ",a" );
-}
-
-# length() on captures, these end up in Perl_magic_len
-{
- my $_ = "aoeu \xe6var ook";
- /^ \w+ \s (?<eek>\S+)/x;
-
- iseq( length($`), 0, 'length $`' );
- iseq( length($'), 4, q[length $'] );
- iseq( length($&), 9, 'length $&' );
- iseq( length($1), 4, 'length $1' );
- iseq( length($+{eek}), 4, 'length $+{eek} == length $1' );
-}
-
# Put new tests above the dotted line about a page above this comment
iseq(0+$::test,$::TestCount,"Got the right number of tests!");
# Don't forget to update this!
BEGIN {
- $::TestCount = 1950;
+ $::TestCount = 1960;
print "1..$::TestCount\n";
}
-
-
## This range will have to adjust as the number of tests expands,
## as it's counting the number of .t files in src/t
##
-my ($min, $max) = (140, 160);
+my ($min, $max) = (150, 170);
if (@D > $min && @D < $max) { print "ok 2\n"; }
else {
printf "not ok 2 # counting op/*.t, expect $min < %d < $max files\n",
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+# Do a basic test on all the tied methods of Tie::Hash::NamedCapture
+
+print "1..12\n";
+
+"hlagh" =~ /
+ (?<a>.)
+ (?<b>.)
+ (?<a>.)
+ .*
+ (?<e>$)
+/x;
+
+# FETCH
+is($+{a}, "h", "FETCH");
+is($+{b}, "l", "FETCH");
+is($-{a}[0], "h", "FETCH");
+is($-{a}[1], "a", "FETCH");
+
+# STORE
+eval { $+{a} = "yon" };
+ok(index($@, "read-only") != -1, "STORE");
+
+# DELETE
+eval { delete $+{a} };
+ok(index($@, "read-only") != -1, "DELETE");
+
+# CLEAR
+eval { %+ = () };
+ok(index($@, "read-only") != -1, "CLEAR");
+
+# EXISTS
+ok(exists $+{e}, "EXISTS");
+ok(!exists $+{d}, "EXISTS");
+
+# FIRSTKEY/NEXTKEY
+is(join('|', sort keys %+), "a|b|e", "FIRSTKEY/NEXTKEY");
+
+# SCALAR
+is(scalar(%+), 3, "SCALAR");
+is(scalar(%-), 3, "SCALAR");
/* This file contains the code that implements the functions in Perl's
* UNIVERSAL package, such as UNIVERSAL->can().
+ *
+ * It is also used to store XS functions that need to be present in
+ * miniperl for a lack of a better place to put them. It might be
+ * clever to move them to seperate XS files which would then be pulled
+ * in by some to-be-written build process.
*/
#include "EXTERN.h"
XS(XS_Internals_HvREHASH);
XS(XS_Internals_inc_sub_generation);
XS(XS_re_is_regexp);
-XS(XS_re_regname);
-XS(XS_re_regnames);
-XS(XS_re_regnames_iterinit);
-XS(XS_re_regnames_iternext);
+XS(XS_re_regname);
+XS(XS_re_regnames);
XS(XS_re_regnames_count);
+XS(XS_Tie_Hash_NamedCapture_FETCH);
+XS(XS_Tie_Hash_NamedCapture_STORE);
+XS(XS_Tie_Hash_NamedCapture_DELETE);
+XS(XS_Tie_Hash_NamedCapture_CLEAR);
+XS(XS_Tie_Hash_NamedCapture_EXISTS);
+XS(XS_Tie_Hash_NamedCapture_FIRSTKEY);
+XS(XS_Tie_Hash_NamedCapture_NEXTKEY);
+XS(XS_Tie_Hash_NamedCapture_SCALAR);
+XS(XS_Tie_Hash_NamedCapture_flags);
void
Perl_boot_core_UNIVERSAL(pTHX)
newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
newXSproto("re::regname", XS_re_regname, file, ";$$");
newXSproto("re::regnames", XS_re_regnames, file, ";$");
- newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, "");
- newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$");
newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
+ newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
+ newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
+ newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
+ newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
+ newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
+ newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTKEY, file);
+ newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTKEY, file);
+ newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
+ newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file);
}
}
}
-XS(XS_re_regname)
+XS(XS_re_regnames_count)
{
-
+ REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+ SV * ret;
dVAR;
dXSARGS;
+
+ if (items != 0)
+ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
+
+ SP -= items;
+
+ if (!rx)
+ XSRETURN_UNDEF;
+
+ ret = CALLREG_NAMED_BUFF_COUNT(rx);
+
+ SPAGAIN;
+
+ if (ret) {
+ XPUSHs(ret);
+ PUTBACK;
+ return;
+ } else {
+ XSRETURN_UNDEF;
+ }
+}
+
+XS(XS_re_regname)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
if (items < 1 || items > 2)
- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
- PERL_UNUSED_VAR(cv); /* -W */
- PERL_UNUSED_VAR(ax); /* -Wall */
+ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
+
SP -= items;
- {
- SV * sv = ST(0);
- SV * all;
- regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
- SV *bufs = NULL;
- if (items < 2)
- all = NULL;
- else {
- all = ST(1);
- }
- {
- if (SvPOK(sv) && re && re->paren_names) {
- bufs = CALLREG_NAMEDBUF_FETCH(re,sv,all && SvTRUE(all));
- if (bufs) {
- if (all && SvTRUE(all))
- XPUSHs(newRV(bufs));
- else
- XPUSHs(SvREFCNT_inc(bufs));
- XSRETURN(1);
- }
- }
- XSRETURN_UNDEF;
- }
- PUTBACK;
- return;
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx)
+ XSRETURN_UNDEF;
+
+ if (items == 2 && SvTRUE(ST(1))) {
+ flags = RXf_HASH_ALL;
+ } else {
+ flags = RXf_HASH_ONE;
}
+ ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXf_HASH_REGNAME));
+
+ if (ret) {
+ if (SvROK(ret))
+ XPUSHs(ret);
+ else
+ XPUSHs(SvREFCNT_inc(ret));
+ XSRETURN(1);
+ }
+ XSRETURN_UNDEF;
}
+
XS(XS_re_regnames)
{
- dVAR;
+ dVAR;
dXSARGS;
- if (items < 0 || items > 1)
- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
- PERL_UNUSED_VAR(cv); /* -W */
- PERL_UNUSED_VAR(ax); /* -Wall */
+ REGEXP * rx;
+ U32 flags;
+ SV *ret;
+ AV *av;
+ I32 length;
+ I32 i;
+ SV **entry;
+
+ if (items > 1)
+ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx)
+ XSRETURN_UNDEF;
+
+ if (items == 1 && SvTRUE(ST(0))) {
+ flags = RXf_HASH_ALL;
+ } else {
+ flags = RXf_HASH_ONE;
+ }
+
SP -= items;
- {
- SV * all;
- regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
- IV count = 0;
- if (items < 1)
- all = NULL;
- else {
- all = ST(0);
- }
- {
- if (re && re->paren_names) {
- HV *hv= re->paren_names;
- (void)hv_iterinit(hv);
- while (1) {
- HE *temphe = hv_iternext_flags(hv,0);
- if (temphe) {
- IV i;
- IV parno = 0;
- SV* sv_dat = HeVAL(temphe);
- I32 *nums = (I32*)SvPVX(sv_dat);
- for ( i = 0; i < SvIVX(sv_dat); i++ ) {
- if ((I32)(re->lastcloseparen) >= nums[i] &&
- re->offs[nums[i]].start != -1 &&
- re->offs[nums[i]].end != -1)
- {
- parno = nums[i];
- break;
- }
- }
- if (parno || (all && SvTRUE(all))) {
- STRLEN len;
- char *pv = HePV(temphe, len);
- if ( GIMME_V == G_ARRAY )
- XPUSHs(newSVpvn(pv,len));
- count++;
- }
- } else {
- break;
- }
- }
- }
- if ( GIMME_V == G_ARRAY )
- XSRETURN(count);
- else
- XSRETURN_UNDEF;
- }
- PUTBACK;
- return;
+ ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXf_HASH_REGNAMES));
+
+ SPAGAIN;
+
+ SP -= items;
+
+ if (!ret)
+ XSRETURN_UNDEF;
+
+ av = (AV*)SvRV(ret);
+ length = av_len(av);
+
+ for (i = 0; i <= length; i++) {
+ entry = av_fetch(av, i, FALSE);
+
+ if (!entry)
+ Perl_croak(aTHX_ "NULL array element in re::regnames()");
+
+ XPUSHs(*entry);
}
+ PUTBACK;
+ return;
}
-
-XS(XS_re_regnames_iterinit)
+XS(XS_Tie_Hash_NamedCapture_FETCH)
{
- dVAR;
+ dVAR;
dXSARGS;
- if (items != 0)
- Perl_croak(aTHX_ "Usage: re::regnames_iterinit()");
- PERL_UNUSED_VAR(cv); /* -W */
- PERL_UNUSED_VAR(ax); /* -Wall */
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx)
+ XSRETURN_UNDEF;
+
SP -= items;
- {
- regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
- if (re && re->paren_names) {
- (void)hv_iterinit(re->paren_names);
- XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
- } else {
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
+ ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
+
+ SPAGAIN;
+
+ if (ret) {
+ if (SvROK(ret))
+ XPUSHs(ret);
+ else
+ XPUSHs(SvREFCNT_inc(ret));
+ PUTBACK;
+ return;
+ }
+ XSRETURN_UNDEF;
+}
+
+XS(XS_Tie_Hash_NamedCapture_STORE)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+
+ if (items != 3)
+ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $value, $flags)");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx) {
+ if (!PL_localizing)
+ Perl_croak(aTHX_ PL_no_modify);
+ else
XSRETURN_UNDEF;
- }
- PUTBACK;
- return;
}
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
+ CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
}
+XS(XS_Tie_Hash_NamedCapture_DELETE)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+ U32 flags;
-XS(XS_re_regnames_iternext)
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)");
+
+ if (!rx)
+ Perl_croak(aTHX_ PL_no_modify);
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
+ CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
+}
+
+XS(XS_Tie_Hash_NamedCapture_CLEAR)
{
- dVAR;
+ dVAR;
dXSARGS;
- if (items < 0 || items > 1)
- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "[all]");
- PERL_UNUSED_VAR(cv); /* -W */
- PERL_UNUSED_VAR(ax); /* -Wall */
+ REGEXP * rx;
+ U32 flags;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx)
+ Perl_croak(aTHX_ PL_no_modify);
+
SP -= items;
- {
- SV * all;
- regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
- if (items < 1)
- all = NULL;
- else {
- all = ST(0);
- }
- if (re && re->paren_names) {
- HV *hv= re->paren_names;
- while (1) {
- HE *temphe = hv_iternext_flags(hv,0);
- if (temphe) {
- IV i;
- IV parno = 0;
- SV* sv_dat = HeVAL(temphe);
- I32 *nums = (I32*)SvPVX(sv_dat);
- for ( i = 0; i < SvIVX(sv_dat); i++ ) {
- if ((I32)(re->lastcloseparen) >= nums[i] &&
- re->offs[nums[i]].start != -1 &&
- re->offs[nums[i]].end != -1)
- {
- parno = nums[i];
- break;
- }
- }
- if (parno || (all && SvTRUE(all))) {
- STRLEN len;
- char *pv = HePV(temphe, len);
- XPUSHs(newSVpvn(pv,len));
- XSRETURN(1);
- }
- } else {
- break;
- }
- }
- }
+ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
+ CALLREG_NAMED_BUFF_CLEAR(rx, flags);
+}
+
+XS(XS_Tie_Hash_NamedCapture_EXISTS)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx)
XSRETURN_UNDEF;
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
+ ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
+
+ SPAGAIN;
+
+ XPUSHs(ret);
PUTBACK;
return;
- }
}
+XS(XS_Tie_Hash_NamedCapture_FIRSTKEY)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
-XS(XS_re_regnames_count)
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx)
+ XSRETURN_UNDEF;
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
+ ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
+
+ SPAGAIN;
+
+ if (ret) {
+ XPUSHs(SvREFCNT_inc(ret));
+ PUTBACK;
+ } else {
+ XSRETURN_UNDEF;
+ }
+
+}
+
+XS(XS_Tie_Hash_NamedCapture_NEXTKEY)
{
- regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
- dVAR;
+ dVAR;
dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx)
+ XSRETURN_UNDEF;
- if (items != 0)
- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
- PERL_UNUSED_VAR(cv); /* -W */
- PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
-
- if (re && re->paren_names) {
- XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
+ ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
+
+ SPAGAIN;
+
+ if (ret) {
+ XPUSHs(ret);
} else {
XSRETURN_UNDEF;
}
PUTBACK;
- return;
+}
+
+XS(XS_Tie_Hash_NamedCapture_SCALAR)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx)
+ XSRETURN_UNDEF;
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
+ ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
+
+ SPAGAIN;
+
+ if (ret) {
+ XPUSHs(ret);
+ PUTBACK;
+ return;
+ } else {
+ XSRETURN_UNDEF;
+ }
+}
+
+XS(XS_Tie_Hash_NamedCapture_flags)
+{
+ dVAR;
+ dXSARGS;
+
+ if (items != 0)
+ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::flags()");
+
+ XPUSHs(sv_2mortal(newSVuv(RXf_HASH_ONE)));
+ XPUSHs(sv_2mortal(newSVuv(RXf_HASH_ALL)));
+ PUTBACK;
+ return;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff