package JE::Object::RegExp;
our $VERSION = '0.060';
use strict;
use warnings; no warnings 'utf8';
use overload fallback => 1,
'""'=> 'value';
use Scalar::Util 'blessed';
our @ISA = 'JE::Object';
require JE::Boolean;
require JE::Code;
require JE::Object;
require JE::String;
import JE::Code 'add_line_number';
sub add_line_number;
our @Match;
our @EraseCapture;
#import JE::String 'desurrogify';
#sub desurrogify($);
# Only need to turn these on when Perl starts adding regexp modifiers
# outside the BMP.
# JS regexp features that Perl doesn't have, or which differ from Perl's,
# along with their Perl equivalents
# ^ with /m \A|(?<=[\cm\cj\x{2028}\x{2029}]) (^ with the /m modifier
# matches whenever a Unicode
# line break (not just \n)
# precedes the current position,
# even at the end of the string. In
# Perl, /^/m matches \A|(?<=\n)(?!\z) .)
# $ \z
# $ with /m (?:\z|(?=[\cm\cj\x{2028}\x{2029}]))
# \b (?:(?<=$w)(?!$w)|(?<!$w)(?=$w)) (where $w represents
# \B (?:(?<=$w)(?=$w)|(?<!$w)(?!$w)) [A-Za-z0-9_], because JS
# doesn't include non-ASCII
# word chars in \w)
# . [^\cm\cj\x{2028}\x{2029}]
# \v \cK
# \n \cj (whether \n matches \cj in Perl is system-dependent)
# \r \cm
# \uHHHH \x{HHHH}
# \d [0-9]
# \D [^0-9]
# \s [\p{Zs}\s\ck]
# \S [^\p{Zs}\s\ck]
# \w [A-Za-z0-9_]
# \W [^A-Za-z0-9_]
# [^] (?s:.)
# [] (?!)
# Other differences
#
# A quantifier in a JS regexp will, when repeated, clear all values cap-
# tured by capturing parentheses in the term that it quantifies. This means
# that /((a)?b)+/, when matched against "abb" will leave $2 undefined, even
# though the second () matched "a" the first time the first () matched.
# (The ECMAScript spec says to do it this way, but Safari leaves $2 with
# "a" in it and doesn't clear it on the second iteration of the '+'.) Perl
# does it both ways, and the rules aren't quite clear to me:
#
# $ perl5.8.8 -le '$, = ",";print "abb" =~ /((a)?b)+/;'
# b,
# $ perl5.8.8 -le '$, = ",";print "abb" =~ /((a+)?b)+/;'
# b,a
#
# perl5.9.4 produces the same. perl5.002_01 crashes quite nicely.
#
#
# In ECMAScript, when the pattern inside a (?! ... ) fails (in which case
# the (?!) succeeds), values captured by parentheses within the negative
# lookahead are cleared, such that subsequent backreferences *outside* the
# lookahead are equivalent to (?:) (zero-width always-match assertion). In
# Perl, the captured values are left as they are when the pattern inside
# the lookahead fails:
#
# $ perl5.8.8 -le 'print "a" =~ /(?!(a)b)a/;'
# a
# $ perl5.9.4 -le 'print "a" =~ /(?!(a)b)a/;'
# a
#
#
# In ECMAScript, as in Perl, a pair of capturing parentheses will produce
# the undefined value if the parens were not part of the final match.
# Undefined will still be produced if there is a \digit backreference
# reference to those parens. In ECMAScript, such a back-reference is equiv-
# alent to (?:); in Perl it is equivalent to (?!). Therefore, ECMAScript’s
# \1 is equivalent to Perl’s (?(1)\1). (It would seem, upon testing
# /(?:|())/ vs. /(?:|())\1/ in perl, that the \1 back-reference always suc-
# ceeds, and ends up setting $1 to "" [as opposed to undef]. What is actu-
# ally happening is that the failed \1 causes backtracking, so the second
# alternative in (?:|()) matches, setting $1 to the empty string. Safari,
# incidentally, does what Perl *appears* to do at first glance, *if* the
# backreference itself is within capturing parentheses (as in
# /(?:|())(\1)/).
#
# These issues are solved with embedded code snippets, as explained below,
# where the actual code is.
#
#
# In ECMAScript, case-folding inside the regular expression engine is not
# allowed to change the length of a string. Therefore, "ß" never matches
# /ss/i, and vice versa. I’m disinclined to be ECMAScript compliant in this
# regard though, because it would affect performance. The inefficient solu-
# tion I have in mind is to change /x/i to /(?-i:x)/ for every character
# that has a multi-character uppercase equivalent; and to change /xx/i to
# /(?-i:[Xx][Xx])/ where xx represents a multi-character sequence that
# could match a single character in Perl. The latter is the main problem.
# How are we to find out which character sequences need this? We could
# change /x/i to /[xX]/ for every literal character in the string, but how
# would we take /Σ/ -> /[Σσς]/ into account? And does perl’s regexp engine
# slow down if we feed it a ton of character classes instead of literal
# text? (Need to do some benchmarks.) (If we do fix this, we need to re-
# enable the skipped tests.)
=head1 NAME
JE::Object::RegExp - JavaScript regular expression (RegExp object) class
=head1 SYNOPSIS
use JE;
use JE::Object::RegExp;
$j = new JE;
$js_regexp = new JE::Object::RegExp $j, "(.*)", 'ims';
$perl_qr = $js_regexp->value;
$some_string =~ $js_regexp; # You can use it as a qr//
=head1 DESCRIPTION
This class implements JavaScript regular expressions for JE.
See L<JE::Types> for a description of most of the interface. Only what
is specific to JE::Object::RegExp is explained here.
A RegExp object will stringify the same way as a C<qr//>, so that you can
use C<=~> on it. This is different from the return value of the
C<to_string> method (the way it stringifies in JS).
Since JE's regular expressions use Perl's engine underneath, the
features that Perl provides that are not part of the ECMAScript spec are
supported, except for C<(?s)>
and C<(?m)>, which don't do anything, and C<(?|...)>, which is
unpredictable.
In versions prior to 0.042, a hyphen adjacent to C<\d>, C<\s> or C<\w> in a
character class would be unpredictable (sometimes a syntax error). Now it
is interpreted literally. This matches what most implementations do, which
happens to be the same as Perl's behaviour. (It is a syntax error
in ECMAScript.)
=head1 METHODS
=over 4
=cut
# ~~~ How should surrogates work??? To make regexps work with JS strings
# properly, we need to use the surrogified string so that /../ will
# correctly match two surrogates. In this case it won't work properly
# with Perl strings, so what is the point of Perl-style stringification?
# Perhaps we should allow this anyway, but warn about code points outside
# the BMP in the documentation. (Should we also produce a Perl warning?
# Though I'm not that it's possible to catch this: "\x{10000}" =~ $re).
#
# But it would be nice if this would work:
# $j->eval("'\x{10000}'") =~ $j->eval('/../')
# ~~~ We might be able to make this work with perl 5.12’s qr overloading.
our %_patterns = qw/
\b (?:(?<=[A-Za-z0-9_])(?![A-Za-z0-9_])|(?<![A-Za-z0-9_])(?=[A-Za-z0-9_]))
\B (?:(?<=[A-Za-z0-9_])(?=[A-Za-z0-9_])|(?<![A-Za-z0-9_])(?![A-Za-z0-9_]))
. [^\cm\cj\x{2028}\x{2029}]
\v \cK
\n \cj
\r \cm
\d [0-9]
\D [^0-9]
\s [\p{Zs}\s\ck]
\S [^\p{Zs}\s\ck]
\w [A-Za-z0-9_]
\W [^A-Za-z0-9_]
/;
our %_class_patterns = qw/
\v \cK
\n \cj
\r \cm
\d 0-9
\s \p{Zs}\s\ck
\w A-Za-z0-9_
/;
my $clear_captures = qr/(?{@Match=@EraseCapture=()})/;
my $save_captures = do { no strict 'refs';
qr/(?{$Match[$_]=$EraseCapture[$_]?undef:$$_ for 1..$#+})/; };
# These are pretty scary, aren’t they?
my $plain_regexp =
qr/^((?:[^\\[()]|\\.|\((?:\?#|\*)[^)]*\))[^\\[()]*(?:(?:\\.|\((?:\?#|\*)[^)]*\))[^\\[()]*)*)/s;
my $plain_regexp_x_mode =
qr/^((?:[^\\[()]|\\.|\(\s*(?:\?#|\*)[^)]*\))[^\\[()]*(?:(?:\\.|\(\s*(?:\?#|\*)[^)]*\))[^\\[()]*)*)/s;
my $plain_regexp_wo_pipe =
qr/^((?:[^\\[()|]|\\.|\((?:\?#|\*)[^)]*\))[^\\[()|]*(?:(?:\\.|\((?:\?#|\*)[^)]*\))[^\\[()|]*)*)/s;
my $plain_regexp_x_mode_wo_pipe =
qr/^((?:[^\\[()|]|\\.|\(\s*(?:\?#|\*)[^)]*\))[^\\[()|]*(?:(?:\\.|\(\s*(?:\?#|\*)[^)]*\))[^\\[()|]*)*)/s;
sub _capture_erasure_stuff {
"(?{local\@EraseCapture[" . join(',',@{$_[0]}) . "]=(1)x"
. @{$_[0]} . '})'
}
sub new {
my ($class, $global, $re, $flags) = @_;
my $self = $class->SUPER::new($global, {
prototype => $global->prototype_for('RegExp')
|| $global->prop('RegExp')->prop('prototype')
});
my $qr;
if(defined blessed $re) {
if ($re->isa(__PACKAGE__)) {
defined $flags && eval{$flags->id} ne 'undef' and
die JE::Object::Error::TypeError->new(
$global, add_line_number
'Second argument to ' .
'RegExp() must be undefined if ' .
'first arg is a RegExp');
$flags = $$$re{regexp_flags};
$qr = $$$re{value};
$re = $re->prop('source')->[0];
}
elsif(can $re 'id' and $re->id eq 'undef') {
$re = '';
}
elsif(can $re 'to_string') {
$re = $re->to_string->value16;
}
}
else {
defined $re or $re = '';
}
if(defined blessed $flags) {
if(can $flags 'id' and $flags->id eq 'undef') {
$flags = '';
}
elsif(can $flags 'to_string') {
$flags = $flags->to_string->value;
}
}
else {
defined $flags or $flags = '';
}
# Let's begin by processing the flags:
# Save the flags before we start mangling them
$$$self{regexp_flags} = $flags;
$self->prop({
name => global =>
value => JE::Boolean->new($global, $flags =~ y/g//d),
dontenum => 1,
readonly => 1,
dontdel => 1,
});
# $flags = desurrogify $flags;
# Not necessary, until Perl adds a /𐐢 modifier (not likely)
# I'm not supporting /s (at least not for now)
no warnings 'syntax'; # so syntax errors in the eval are kept quiet
$flags =~ /^((?:(?!s)[\$_\p{ID_Continue}])*)\z/ and eval "qr//$1"
or die new JE::Object::Error::SyntaxError $global,
add_line_number "Invalid regexp modifiers: '$flags'";
my $m = $flags =~ /m/;
$self->prop({
name => ignoreCase =>
value => JE::Boolean->new($global, $flags =~ /i/),
dontenum => 1,
readonly => 1,
dontdel => 1,
});
$self->prop({
name => multiline =>
value => JE::Boolean->new($global, $m),
dontenum => 1,
readonly => 1,
dontdel => 1,
});
# Now we'll deal with the pattern itself.
# Save it before we go and mangle it
$self->prop({
name => source =>
# ~~~ Can we use ->_new here?
value => JE::String->new($global, $re),
dontenum => 1,
readonly => 1,
dontdel => 1,
});
unless (defined $qr) { # processing begins here
# This horrific piece of code converts an ECMAScript regular
# expression into a Perl one, more or less.
# Since Perl sometimes fills in $1, etc., where they are supposed
# to be undefined in ECMAScript, we use embedded code snippets to
# put the values into @Match[1..whatever] instead.
# The cases we have to take into account are
# 1) quantified captures; i.e., (...)+ or (?:()?)+ ; and
# 2) captures within interrobang groups: (?!())
# The solution is to mark captures as erasure candidates with the
# @EraseCapture array.
# To solve case 1, we have to put (?{}) markers at the begin-
# ning of each grouping construct that has captures in it,
# and a quantifier within each pair of capturing parenthe-
# ses before the closing paren. (?:(a+)?b)+ will become
# (?: (?{...}) ( a+ (?{...}) )? b )+ (spaced out for reada-
# bility). The first code interpolation sets $EraseCapture[n]
# to 1 for all the captures within that group. The sec-
# ond code interpolation will only be triggered if the a+
# matches, and there we set $EraseCapture[n] to 0. It’s actu-
# ally slightly more complicated than that, because we may
# have alternatives directly inside the outer grouping; e.g.,
# (?:a|(b))+, so we have to wrap the contents thereof within
# (?:), making ‘(?:(?{...})(?:a|(b(?{...}))))+’. Whew!
# For case 2 we change (?!...) to (?:(?!...)(?{...})). The embedded
# code marks the captures inside (?!) for erasure. The (?: is
# needed because the (?!) might be quantified. (We used not to add
# the extra (?:), but put the (?{}) at the end of the innermost
# enclosing group, but that causes the same \1 problem men-
# tioned above.
use constant 1.03 # multiple
{ # Make any changes to these constants are also made at the end
# of the subroutine
# array indices within each item on the @stack:
posi => 0, # position within $new_re where the current
# group’s contents start, or before the opening
# paren for interrobang groups
type => 1, # type of group; see constants below
xmod => 2, # whether /x mode is active
capn => 3, # array ref of capture numbers within this group
# types of parens:
reg => 0, cap => 1, itrb => 2, brch => 3, cond => 4
};
my $new_re = '';
my $sub_pat;
my @stack = [0,0,$flags =~ /x/];
my $capture_num; # number of the most recently started capture
my @capture_nums; # numbers of the captures we’re inside
#my $warn;
#++$warn if $re eq '(?p{})';
{
@stack or die new JE::Object::Error::SyntaxError $global,
add_line_number "Unmatched ) in regexp";
# no parens or char classes:
if( $stack[-1][xmod]
? $stack[-1][type] == cond || $stack[-1][type] == brch
? $re =~ s/$plain_regexp_x_mode_wo_pipe//
: $re =~ s/$plain_regexp_x_mode//
: $stack[-1][type] == cond || $stack[-1][type] == brch
? $re =~ s/$plain_regexp_wo_pipe//
: $re =~ s/$plain_regexp//
) {
($sub_pat = $1) =~
s/
([\^\$])
|
(\.|\\[bBvnrdDsSwW])
|
\\u([A-Fa-f0-9]{4})
|
\\([1-9][0-9]*)
|
\\?([\x{d800}-\x{dfff}])
|
(\\(?:[^c]|c.))
/
defined $1
? $1 eq '^'
? $m
? '(?:\A|(?<=[\cm\cj\x{2028}\x{2029}]))'
: '^'
: $m
? '(?:\z|(?=[\cm\cj\x{2028}\x{2029}]))'
: '\z'
: defined $2 ? $_patterns{$2} :
defined $3 ? "\\x{$3}" :
defined $4 ? "(?(?{defined\$$4&&"
."!\$EraseCapture[$4]})\\$4)" :
# work around a bug in perl:
defined $5 ? sprintf '\\x{%x}', ord $5 :
$6
/egxs;
$new_re .= $sub_pat;
}
# char class:
elsif($re=~s/^\[([^]\\]*(?:\\.[^]\\]*)*)]//s){
if($1 eq '') {
$new_re .= '(?!)';
}
elsif($1 eq '^') {
$new_re .= '(?s:.)';
}
else {
my @full_classes;
($sub_pat = $1) =~ s/
(\\[vnr])
|
(-?)(\\[dsw])(-?)
|
(\\[DSW])
|
\\u([A-Fa-f0-9]{4})
|
\\?([\x{d800}-\x{dfff}])
|
(\\(?:[^c]|c.))
/
defined $1 ? $_class_patterns{$1} :
defined $3 ?
($2 ? '\-' : '')
.$_class_patterns{$3}
.($4 ? '\-' : '') :
defined $5 ? ((push @full_classes,
$_patterns{$5}),'') :
defined $6 ? "\\x{$6}" :
# work around a bug in perl:
defined $7 ? sprintf '\\x{%x}', ord $7 :
$8
/egxs;
$new_re .= length $sub_pat
? @full_classes
? '(?:' .
join('|', @full_classes,
"[$sub_pat]")
. ')'
: "[$sub_pat]"
: @full_classes == 1
? $full_classes[0]
: '(?:' . join('|', @full_classes) .
')';
}
}
# (?mods) construct (no colon) :
elsif( $stack[-1][xmod]
? $re =~ s/^(\(\s*\?([\w]*)(?:-([\w]*))?\))//
: $re =~ s/^(\( \?([\w]*)(?:-([\w]*))?\))//x
) {
$new_re .= $1;
defined $3 && index($3,'x')+1
? $stack[-1][xmod]=0
: $2 =~ /x/ && ++$stack[-1][xmod];
}
# start of grouping construct:
elsif( $stack[-1][xmod]
? $re=~s/^(\((?:\s*\?([\w-]*:|[^:{?<p]|<.|([?p]?\{)))?)//
: $re=~s/^(\((?: \?([\w-]*:|[^:{?<p]|<.|([?p]?\{)))?)//x
) {
# warn "$new_re-$1-$2-$3-$re" if $warn;
$3 and die JE'Object'Error'SyntaxError->new(
$global, add_line_number
"Embedded code in regexps is not "
. "supported"
);
my $pos_b4_parn = length $new_re;
$new_re .= $1;
my $caq = $2; # char(s) after question mark
my @current;
if(defined $caq) { # (?...) patterns
if($caq eq '(') {
$re =~ s/^([^)]*\))//;
$new_re .= $1;
$1 =~ /^\?[?p]?\{/ && die
JE'Object'Error'SyntaxError->new(
$global, add_line_number
"Embedded code in regexps is not "
. "supported"
);
$current[type] = cond;
}
elsif($caq =~ /^[<'P](?![!=])/) {
++$capture_num;
$caq eq "'" ? $re =~ s/^(.*?')//
: $re =~ s/^(.*?>)//;
$new_re .= $1;
$current[type] = reg;
}
else {
$current[type] = (reg,itrb)[$caq eq '!'];
}
$current[posi] = $caq eq '!' ? $pos_b4_parn
: length $new_re;
}else{ # capture
++$capture_num;
push @capture_nums, $capture_num;
push @{$$_[capn]}, $capture_num for @stack;
$current[posi] = length $new_re;
$current[type] = cap;
}
$current[xmod] = $stack[-1][xmod];
push @stack, \@current;
}
# closing paren:
elsif($re =~ s/^\)//) {
my @commands;
my $cur = $stack[-1];
if($$cur[type] != itrb) {
if($$cur[type] == cap) {
# we are exiting a capturing group
$new_re .= "(?{local" .
"\$EraseCapture[$capture_nums[-1]]=0"
."})";
pop @capture_nums;
}
if($$cur[capn] && @{$$cur[capn]} &&
$re =~ /^[+{*?]/) { # quantified group
substr $new_re,$$cur[posi],0 =>=
_capture_erasure_stuff($$cur[capn])
. "(?:";
$new_re .= ")";
}
$new_re .= ')';
}
else {{ # ?!
$new_re .= ')';
last unless($$cur[capn] && @{$$cur[capn]});
# change (?!...) to (?!...)(?{...})
$new_re .= _capture_erasure_stuff(
$$cur[capn]
);
# wrap (?!)(?{}) in (?:) if necessary
$re =~ /^[+{*?]/ and
substr $new_re,$$cur[posi],0
=>= '(?:',
$new_re .= ')';
}}
pop @stack;
}
# pipe within (?()|) or (?|) (the latter doesn’t work yet):
elsif($re =~ s/^\|//) {
my $cur = $stack[-1];
if($$cur[capn] && @{$$cur[capn]}
#&& $re =~ /^[+{*?]/ # We can’t actually tell
) { # at this point whether the enclosing
# group is quantified. Does anyone have any ideas?
substr $new_re,$$cur[posi],0 =>=
_capture_erasure_stuff(
$$cur[capn]
);
@{$$cur[capn]} = ();
}
$new_re .= '|';
$$cur[posi] = length $new_re;
}
# something invalid left over:
elsif($re) {
#warn $re;
die JE::Object::Error::SyntaxError->new($global,
add_line_number
$re =~ /^\[/
? "Unterminated character class $re in regexp"
: 'Trailing \ in regexp');
}
length $re and redo;
}
@stack or die new JE::Object::Error::SyntaxError $global,
add_line_number "Unmatched ) in regexp";
#warn $new_re;
$qr = eval {
use re 'eval'; no warnings 'regexp'; no strict;
# The warnings pragma doesn’t make it into the re-eval, so
# we have to localise $^W, in case the string contains
# @EraseCapture[1]=(1)x1 and someone is using -w.
local $^W;
# We have to put (?:) around $new_re in the first case,
# because it may contain a top-level disjunction, but
# not in the second, because the array modifica-
$capture_num # tions in $clear_captures are not localised.
? qr/(?$flags:$clear_captures(?:$new_re)$save_captures)/
: qr/(?$flags:$clear_captures$new_re)/
} or $@ =~ s/\.?$ \n//x,
die JE::Object::Error::SyntaxError->new($global,
add_line_number $@);
} # end of pattern processing
$$$self{value} = $qr;
$self->prop({
name => lastIndex =>
value => JE::Number->new($global, 0),
dontdel => 1,
dontenum => 1,
});
$self;
}
BEGIN {
no strict;
delete @{__PACKAGE__.'::'}{qw[posi type xmod capn reg cap itrb brch cond]}
}
=item value
Returns a Perl C<qr//> regular expression.
If the regular expression
or the string that is being matched against it contains characters outside
the Basic Multilingual Plane (whose character codes exceed 0xffff), the
behavior is undefined--for now at least. I still need to solve the problem
caused by JS's unintuitive use of raw surrogates. (In JS, C</../> will
match a
surrogate pair, which is considered to be one character in Perl. This means
that the same regexp matched against the same string will produce different
results in Perl and JS.)
=cut
sub value {
$${$_[0]}{value};
}
=item class
Returns the string 'RegExp'.
=cut
sub class { 'RegExp' }
sub call {
my ($self,$str) = @_;
die JE::Object::Error::TypeError->new(
$self->global, add_line_number
"Argument to exec is not a " .
"RegExp object"
) unless $self->class eq 'RegExp';
my $je_str;
if (defined $str) {
$str =
($je_str=$str->to_string)->value16;
}
else {
$str = 'undefined';
}
my(@ary,$indx);
my $global = $$$self{global};
my $g = $self->prop('global')->value;
if ($g) {
my $pos =
$self->prop('lastIndex')
->to_number->value;
$pos < 0 || $pos > length $str
||
(
pos $str = $pos,
$str !~ /$$$self{value}/g
)
and goto phail;
@ary = @Match;
$ary[0] = substr($str, $-[0],
$+[0] - $-[0]);
$indx = $-[0];
$self->prop(lastIndex =>
JE::Number->new(
$global,
pos $str
));
$global->prototype_for('RegExp')
->prop('constructor')
->capture_re_vars($str);
}
else {
$str =~ /$$$self{value}/
or goto phail;
@ary = @Match;
$ary[0] = substr($str, $-[0],
$+[0] - $-[0]);
$indx = $-[0];
$global->prototype_for('RegExp')
->prop('constructor')
->capture_re_vars($str);
}
my $ary = JE::Object::Array->new(
$global,
\@ary
);
$ary->prop(index =>
JE::Number->new($global,$indx));
$ary->prop(input => defined $je_str
? $je_str :
JE::String->_new(
$global, $str
));
return $ary;
phail:
$self->prop(lastIndex =>
JE::Number->new(
$global,
0
));
return $global->null;
}
sub apply { splice @'_, 1, 1; goto &call }
@JE::Object::Function::RegExpConstructor::ISA = 'JE::Object::Function';
sub JE::Object::Function::RegExpConstructor::capture_re_vars {
my $self = shift;
my $global = $$$self{global};
$self->prop(
'lastMatch',
JE::String->new($global, substr $_[0], $-[0], $+[0]-$-[0])
);
{
no warnings 'uninitialized';
$self->prop('lastParen', new JE::String $global, "$+")
}
$self->prop(
'leftContext',
new JE'String $global, substr $_[0], 0, $-[0]
);
$self->prop('rightContext', new JE'String $global, substr $_[0], $+[0]);
no warnings 'uninitialized';
$self->prop("\$$_", new JE'String $global, "$Match[$_]") for 1..9;
}
sub new_constructor {
my($package,$global) = @_;
my $f = JE::Object::Function::RegExpConstructor->new({
name => 'RegExp',
scope => $global,
argnames => [qw/pattern flags/],
function => sub {
my (undef, $re, $flags) = @_;
if ($re->class eq 'RegExp' and !defined $flags
|| $flags->id eq 'undef') {
return $re
}
unshift @_, __PACKAGE__;
goto &new;
},
function_args => ['scope','args'],
constructor => sub {
unshift @_, $package;
goto &new;
},
constructor_args => ['scope','args'],
});
my $proto = $f->prop({
name => 'prototype',
dontenum => 1,
readonly => 1,
});
$global->prototype_for('RegExp', $proto);
$f->prop({
name => '$&',
dontdel => 1,
fetch => sub { shift->prop('lastMatch') },
store => sub { shift->prop('lastMatch', shift) },
});
$f->prop({
name => '$`',
dontdel => 1,
fetch => sub { shift->prop('leftContext') },
store => sub { shift->prop('leftContext', shift) },
});
$f->prop({
name => '$\'',
dontdel => 1,
fetch => sub { shift->prop('rightContext') },
store => sub { shift->prop('rightContext', shift) },
});
$f->prop({
name => '$+',
dontdel => 1,
fetch => sub { shift->prop('lastParen') },
store => sub { shift->prop('lastParen', shift) },
});
my $empty = JE::String->new($global,"");
for(
qw(lastParen lastMatch leftContext rightContext),
map "\$$_", 1..9
) {
$f->prop({ name => $_, dontdel => 1, value => $empty});
}
$proto->prop({
name => 'exec',
value => JE::Object::Function->new({
scope => $global,
name => 'exec',
argnames => ['string'],
no_proto => 1,
function_args => ['this','args'],
function => \&call,
}),
dontenum => 1,
});
$proto->prop({
name => 'test',
value => JE::Object::Function->new({
scope => $global,
name => 'test',
argnames => ['string'],
no_proto => 1,
function_args => ['this','args'],
function => sub {
my ($self,$str) = @_;
die JE::Object::Error::TypeError->new(
$global, add_line_number
"Argument to test is not a " .
"RegExp object"
) unless $self->class eq 'RegExp';
my $ret = call($self,$str);
JE::Boolean->new(
$global, $ret->id ne 'null'
);
},
}),
dontenum => 1,
});
$proto->prop({
name => 'toString',
value => JE::Object::Function->new({
scope => $global,
name => 'toString',
no_proto => 1,
function_args => ['this'],
function => sub {
my ($self,) = @_;
die JE::Object::Error::TypeError->new(
$global, add_line_number
"Argument to toString is not a " .
"RegExp object"
) unless $self->class eq 'RegExp';
JE::String->_new(
$global,
"/" . $self->prop('source')->value
. "/$$$self{regexp_flags}"
);
},
}),
dontenum => 1,
});
$f;
}
=back
=head1 SEE ALSO
=over 4
=item JE
=item JE::Types
=item JE::Object
=cut