Perl6-Pugs/perl5/PIL2JS/lib6/Prelude/JS/Rules.pm
# This file is an unfinished sketch of :perl5 regex support.
sub JS::Root::rxbare_(Str $re) is primitive {
my %h;
rx_helper_(%h, $re, "/", "/");
}
sub JS::Root::rx_(%mods, Str $re, Str $qo, Str $qc) is primitive {
rx_helper_(%mods, $re, $qo, $qc);
}
sub JS::Root::m_(%mods, Str $re, Str $qo, Str $qc) is primitive {
rx_helper_(%mods, $re, $qo, $qc);
}
our(%modifiers_known, %modifiers_supported_p6, %modifiers_supported_p5);
our(%rx_helper_cache);
sub JS::Root::rx_helper_(%mods0, Str $pat0, Str $qo, Str $qc) is primitive {
if !%modifiers_known.keys {
%modifiers_known = map {;($_ => 1)},
<perl5 Perl5 P5 i ignorecase w words g global c continue p pos
once bytes codes graphs langs x nth ov overlap ex exhaustive
rw keepall e each any parsetree>;
%modifiers_supported_p6 = map {;($_ => 1)},
<i ignorecase w words g global>;
%modifiers_supported_p5 = map {;($_ => 1)},
<perl5 Perl5 P5 i ignorecase g global ov overlap>;
%rx_helper_cache{'re_x'} = rx_core_({perl5=>1},'^(\d+)x$','/','/');
%rx_helper_cache{'re_nth'} = rx_core_({perl5=>1},'^(\d+)(?:th|st|nd|rd)$','/','/');
}
my $pat = $pat0;
my %mods = %mods0;
my $p5 = %mods{"perl5"} || %mods{"Perl5"} || %mods{"P5"};
my sub warning($e){warn("Warning: $e")};
for %mods.keys -> $k {
if %modifiers_known{$k} {
if $p5 && !%modifiers_supported_p5{$k} {
warning "Modifier :$k is not (yet?) supported by :perl5 regexps.";
} elsif !$p5 && !%modifiers_supported_p6{$k} {
warning "Modifier :$k is not yet supported by PGE/pugs.";
}
}
elsif (($k.chars > 1) && (substr($k,-1,1) eq "x") # XXX - excess parens required
&& ($k ~~ %rx_helper_cache{'re_x'})) {
my $n = 0+ ~$0; # +$0 XXX
%mods.delete($k);
%mods{'x'} = $n;
}
elsif (($k.chars > 2) && (substr($k,-2,2) eq ("th"|"st"|"nd"|"rd"))
&& ($k ~~ %rx_helper_cache{'re_nth'})) {
my $n = 0+ ~$0; # +$0 XXX
%mods.delete($k);
%mods{'nth'} = $n;
}
else {
my $msg = "Unknown modifier :$k will probably be ignored.";
$msg ~= " Perhaps you meant :i:s ?" if $k eq ("is"|"si");
warning $msg;
}
}
if !$p5 {
die "Perl 6 Rules are not supported." if !$perl5;
}
rx_core_(%mods,$pat,$qo,$qc);
}
sub JS::Root::rx_core_(%mods, Str $pat, Str $qo, Str $qc) is primitive {
my $global = %mods{'g'} || %mods{'global'};
my $overlap = %mods{'ov'} || %mods{'overlap'};
my $exhaustive = %mods{'ex'} || %mods{'exhaustive'};
my $ignore = %mods{'i'} || %mods{'ignore'};
my $nth = %mods.exists('nth');
my $multiline;
my $new_Match = JS::inline('
PIL2JS.toPIL2JSBox(function (as_b, from, to, as_s, as_a, as_h) {
return new PIL2JS.Match(as_b, from, to, as_s, as_a, as_h);
})');
my $matcher;
if $global {
my %mods_altered = %mods;
%mods_altered.delete('g');
%mods_altered.delete('global');
my $rx = rx_core_(%mods_altered,$pat,$qo,$qc);
$matcher = sub ($string) {
my $s = ~$string;
my $offset = 0;
my @a;
while 1 {
my $m = $s ~~ $rx;
last if !$m;
push(@a,$m);
my $off = $m.to +1;
# $m.from += $offset; # XXX - should be writable, but isnt.
# $m.to += $offset; # XXX - should be writable, but isnt.
last if $s eq '';
$offset += $off;
$s = substr($s,$off);
}
my $match;
if !@a {
$match = $new_Match(?0, undef, undef, "", [], ());
} else {
my $from = @a[0].from;
my $to = $offset -1; # @a[-1].to; # XXX - .to is incorrect - see above
my $str = substr($string,$from,$to-$from+1);
$match = $new_Match(?1, $from, $to, $str, @a, ());
}
$/ := $match;
};
} elsif $nth {
my %mods_altered = %mods;
%mods_altered.delete('nth');
%mods_altered{'global'} = 1;
my $rx = rx_core_(%mods_altered,$pat,$qo,$qc);
my $nth_keys = %mods{'nth'};
$matcher = sub ($string) {
my $m = $string ~~ $rx;
return $m if !$m;
my @a = @$m; # XXX Error: Can't use "[object Object]" as a generic reference!
@a = map {$_[0]}, @$m if @(@a[0]);
unshift(@a,undef); # 1-based.
@a[$nth_keys];
};
} elsif $overlap {
my %mods_altered = %mods;
%mods_altered.delete('ov');
%mods_altered.delete('overlap');
my $rx = rx_core_(%mods_altered,$pat,$qo,$qc);
$matcher = sub ($string) {
my $pos = 0; my $a = []; my $prev = -1; my $m;
while 1 {
my $s = substr($string,$pos) // last;
$m = $s ~~ $rx or last;
last if !$m; # XXX - should be caught by or last;
my $m0 = $m[0] // $m;
my $at = $pos + $m0.from;
$a.push($m0) if $at > $prev; $prev = $at;
$pos += $m.from + 1;
}
# 0 ?? ([|] @$a) !! $a; # XXX - 0 should be want.Item
$a;
};
} else {
my $pattern = $pat;
if (substr($pattern,0,2) eq '(?') {
if substr($pattern,0,4) eq '(?i)' { # XXX - kludge - use regex
$pattern = substr($pattern,4);
$ignore = 1;
}
if substr($pattern,0,4) eq '(?m)' {
$pattern = substr($pattern,4);
$multiline = 1;
}
# TODO - x
}
# TODO - \A \Z \z
my $flags = "";
$flags ~= "i" if $ignore;
$flags ~= "m" if $multiline;
$matcher = sub ($string) { # XXX - Are things getting boxed?
my $ret = JS::inline('(
function (pattern,flags,string) {
var mkMatch = function (ok, from, to, s, a, h) {
return new PIL2JS.Match(ok, from, to, s, a, h);
};
var unpack_match = function (match) {
var from = match.index;
var str = match[0];
var to = from + str.length -1;
var arr = [];
for(var i = 1; i < match.length; i++) {
var s = match[i];
var tf = s != null;
if (!tf) { s = "" }
arr.push( mkMatch(tf, null,null, s, null,null));
}
var m = mkMatch(true, from, to, str, arr, null);
return m;
};
var regexp;
try { // Guard against malformed patterns.
regexp = new RegExp(pattern,flags);
} catch (e) {
return null;
}
var match = regexp.exec(string);
if (!match) {
return mkMatch(false, null,null, null, null,null);
}
var m = unpack_match(match);
return m;
}
)')(~$pattern,$flags,~$string);
if !defined $ret { # XXX - should really be die, not warn.
warn "JavaScript RegExp syntax error in /$pattern/.\n";
$ret = $new_Match(?0, undef, undef, "", [], ());
}
$/ := $ret;
};
}
JS::inline('(function (matcher) { return new PIL2JS.Rul(matcher) })')($matcher);
}
method JS::Root::matcher (Rul $rule:) {
JS::inline('(function (rul) { return rul.matcher })')($rule);
}
for <ok from to str subpos subnamed> -> $attr {
Pugs::Internals::eval_perl6 "method JS::Root::$attr (Match \$match:) \{
JS::inline('(function (match) \{ return match.$attr \})')(\$match);
\}";
}
# Needs PIL2 and MMD to be done without hacks
sub PIL2JS::Internals::Hacks::postcircumfix_for_match_objects (
Match $match, Int *@idxs
) is primitive {
$match.subpos[@idxs];
}
sub PIL2JS::Internals::Hacks::init_match_postcircumfix_method () is primitive {
JS::inline('(function () {
PIL2JS.addmethod(
_3aMain_3a_3aMatch,
"postcircumfix:[]",
_26PIL2JS_3a_3aInternals_3a_3aHacks_3a_3apostcircumfix_for_match_objects
);
})')();
}
# $0 etc. are aliases for $/[0] etc.
# Here is an old JS version of :global. Fyi.
# var regexp = new RegExp(pattern,flags + "g");
# var match = regexp.exec(string);
# if (!match) {
# return mkMatch(false, null,null, null, null,null);
# }
# var g_from = match.index;
# var g_array = [];
# var g_to;
# while (match) {
# var m = unpack_match(match);
# g_array.push(m);
# g_to = regexp.lastIndex - 1;
# match = regexp.exec(string);
# }
# var g_str = string.substring(g_from,g_to+1);
# var m = mkMatch(true, g_from, g_to, g_str, g_array, null);
# return m;