Skip to content

Commit 052dbfb

Browse files
TimToadyTimToady
committed
whack in t/spec -> roast change
1 parent 94479be commit 052dbfb

34 files changed

+96557
-7
lines changed

‎Cursor.pm5

Lines changed: 142 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,142 @@
1+
use 5.010;
2+
use utf8;
3+
use CursorBase;
4+
{ package Cursor;
5+
use Moose ':all' => { -prefix => "moose_" };
6+
use Encode;
7+
moose_extends('CursorBase');
8+
our $ALLROLES = { 'Cursor', 1 };
9+
our $REGEXES = {
10+
ALL => [ qw// ],
11+
};
12+
13+
14+
no warnings 'qw', 'recursion';
15+
my $retree;
16+
17+
$DB::deep = $DB::deep = 1000; # suppress used-once warning
18+
19+
use YAML::XS;
20+
21+
$SIG{__WARN__} = sub { die @_," statement started at line ", 'Cursor'->lineof($::LASTSTATE), "
22+
" } if $::DEBUG;
23+
24+
;
25+
our $BLUE = $CursorBase::BLUE;
26+
our $GREEN = $CursorBase::GREEN;
27+
our $CYAN = $CursorBase::CYAN;
28+
our $MAGENTA = $CursorBase::MAGENTA;
29+
our $YELLOW = $CursorBase::YELLOW;
30+
our $RED = $CursorBase::RED;
31+
our $CLEAR = $CursorBase::CLEAR;
32+
## method panic (Str $s)
33+
sub panic {
34+
no warnings 'recursion';
35+
my $self = shift;
36+
die 'Required argument s omitted' unless @_;
37+
my $s = @_ ? shift() : undef;
38+
$self->deb("panic $s") if $::DEBUG;
39+
my $m;
40+
my $here = $self;
41+
$m .= $s;
42+
$m .= $here->locmess;
43+
$m .= "\n" unless $m =~ /\n$/;
44+
print STDERR $Cursor::RED, '===', $Cursor::CLEAR, 'SORRY!', $Cursor::RED, '===', $Cursor::CLEAR, "\n";
45+
print STDERR $m;
46+
die "Parse failed\n";
47+
};
48+
## method worry (Str $s)
49+
sub worry {
50+
no warnings 'recursion';
51+
my $self = shift;
52+
die 'Required argument s omitted' unless @_;
53+
my $s = @_ ? shift() : undef;
54+
my $m = $s . $self->locmess;
55+
push @::WORRIES, $m unless $::WORRIES{$s}++;
56+
$self;
57+
};
58+
## method sorry (Str $s)
59+
sub sorry {
60+
no warnings 'recursion';
61+
my $self = shift;
62+
die 'Required argument s omitted' unless @_;
63+
my $s = @_ ? shift() : undef;
64+
$self->deb("sorry $s") if $::DEBUG;
65+
print STDERR $Cursor::RED, '===', $Cursor::CLEAR, 'SORRY!', $Cursor::RED, '===', $Cursor::CLEAR, "\n"
66+
unless $::IN_SUPPOSE or $::FATALS++;
67+
if ($s) {
68+
my $m = $s;
69+
$m .= $self->locmess . "\n" unless $m =~ /\n$/;
70+
if ($::FATALS > 10 or $::IN_SUPPOSE) {
71+
die $m}
72+
else {
73+
print STDERR $m unless $::WORRIES{$m}++};
74+
};
75+
$self;
76+
};
77+
## method locmess ()
78+
sub locmess {
79+
no warnings 'recursion';
80+
my $self = shift;
81+
my $pos = $self->{'_pos'};
82+
my $line = $self->lineof($pos);
83+
if ($pos >= @::MEMOS - 1) {
84+
$pos = $pos - 1;
85+
$line = $line . " (EOF)";
86+
};
87+
my $pre = substr($::ORIG, 0, $pos);
88+
$pre = substr($pre, -40, 40);
89+
1 while $pre =~ s!.*\n!!;
90+
$pre = '<BOL>' if $pre eq '';
91+
my $post = substr($::ORIG, $pos, 40);
92+
1 while $post =~ s!(\n.*)!!;
93+
$post = '<EOL>' if $post eq '';
94+
" at " . $::FILE->{'name'} . " line $line:\n------> " . $Cursor::GREEN . $pre . $Cursor::YELLOW . $::PERL6HERE . $Cursor::RED .
95+
"$post$Cursor::CLEAR";
96+
};
97+
## method line
98+
sub line {
99+
no warnings 'recursion';
100+
my $self = shift;
101+
$self->lineof($self->{'_pos'})};
102+
## method lineof ($p)
103+
sub lineof {
104+
no warnings 'recursion';
105+
my $self = shift;
106+
die 'Required argument p omitted' unless @_;
107+
my $p = @_ ? shift() : undef;
108+
return 1 unless defined $p;
109+
my $line = $::MEMOS[$p]->{'L'};
110+
return $line if $line;
111+
$line = 0;
112+
my $pos = 0;
113+
my @text = split(/^/,$::ORIG);
114+
for (@text) {
115+
$line++;
116+
$::MEMOS[$pos++]->{'L'} = $line
117+
for 1 .. length($_);
118+
}
119+
;
120+
$::MEMOS[$pos++]->{'L'} = $line;
121+
return $::MEMOS[$p]->{'L'} // 0;
122+
};
123+
## method SETGOAL
124+
sub SETGOAL {
125+
no warnings 'recursion';
126+
my $self = shift;
127+
};
128+
## method FAILGOAL (Str $stop, Str $name, $startpos)
129+
sub FAILGOAL {
130+
no warnings 'recursion';
131+
my $self = shift;
132+
die 'Required argument stop omitted' unless @_;
133+
my $stop = @_ ? shift() : undef;
134+
die 'Required argument name omitted' unless @_;
135+
my $name = @_ ? shift() : undef;
136+
die 'Required argument startpos omitted' unless @_;
137+
my $startpos = @_ ? shift() : undef;
138+
my $s = "'$stop'";
139+
$s = '"\'"' if $s eq "'''";
140+
$self->panic("Unable to parse $name" . $startpos->locmess . "\nCouldn't find final $s; gave up");
141+
};
142+
1; };

‎Cursor.pmc

Lines changed: 142 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,142 @@
1+
use 5.010;
2+
use utf8;
3+
use CursorBase;
4+
{ package Cursor;
5+
use Moose ':all' => { -prefix => "moose_" };
6+
use Encode;
7+
moose_extends('CursorBase');
8+
our $ALLROLES = { 'Cursor', 1 };
9+
our $REGEXES = {
10+
ALL => [ qw// ],
11+
};
12+
13+
14+
no warnings 'qw', 'recursion';
15+
my $retree;
16+
17+
$DB::deep = $DB::deep = 1000; # suppress used-once warning
18+
19+
use YAML::XS;
20+
21+
$SIG{__WARN__} = sub { die @_," statement started at line ", 'Cursor'->lineof($::LASTSTATE), "
22+
" } if $::DEBUG;
23+
24+
;
25+
our $BLUE = $CursorBase::BLUE;
26+
our $GREEN = $CursorBase::GREEN;
27+
our $CYAN = $CursorBase::CYAN;
28+
our $MAGENTA = $CursorBase::MAGENTA;
29+
our $YELLOW = $CursorBase::YELLOW;
30+
our $RED = $CursorBase::RED;
31+
our $CLEAR = $CursorBase::CLEAR;
32+
## method panic (Str $s)
33+
sub panic {
34+
no warnings 'recursion';
35+
my $self = shift;
36+
die 'Required argument s omitted' unless @_;
37+
my $s = @_ ? shift() : undef;
38+
$self->deb("panic $s") if $::DEBUG;
39+
my $m;
40+
my $here = $self;
41+
$m .= $s;
42+
$m .= $here->locmess;
43+
$m .= "\n" unless $m =~ /\n$/;
44+
print STDERR $Cursor::RED, '===', $Cursor::CLEAR, 'SORRY!', $Cursor::RED, '===', $Cursor::CLEAR, "\n";
45+
print STDERR $m;
46+
die "Parse failed\n";
47+
};
48+
## method worry (Str $s)
49+
sub worry {
50+
no warnings 'recursion';
51+
my $self = shift;
52+
die 'Required argument s omitted' unless @_;
53+
my $s = @_ ? shift() : undef;
54+
my $m = $s . $self->locmess;
55+
push @::WORRIES, $m unless $::WORRIES{$s}++;
56+
$self;
57+
};
58+
## method sorry (Str $s)
59+
sub sorry {
60+
no warnings 'recursion';
61+
my $self = shift;
62+
die 'Required argument s omitted' unless @_;
63+
my $s = @_ ? shift() : undef;
64+
$self->deb("sorry $s") if $::DEBUG;
65+
print STDERR $Cursor::RED, '===', $Cursor::CLEAR, 'SORRY!', $Cursor::RED, '===', $Cursor::CLEAR, "\n"
66+
unless $::IN_SUPPOSE or $::FATALS++;
67+
if ($s) {
68+
my $m = $s;
69+
$m .= $self->locmess . "\n" unless $m =~ /\n$/;
70+
if ($::FATALS > 10 or $::IN_SUPPOSE) {
71+
die $m}
72+
else {
73+
print STDERR $m unless $::WORRIES{$m}++};
74+
};
75+
$self;
76+
};
77+
## method locmess ()
78+
sub locmess {
79+
no warnings 'recursion';
80+
my $self = shift;
81+
my $pos = $self->{'_pos'};
82+
my $line = $self->lineof($pos);
83+
if ($pos >= @::MEMOS - 1) {
84+
$pos = $pos - 1;
85+
$line = $line . " (EOF)";
86+
};
87+
my $pre = substr($::ORIG, 0, $pos);
88+
$pre = substr($pre, -40, 40);
89+
1 while $pre =~ s!.*\n!!;
90+
$pre = '<BOL>' if $pre eq '';
91+
my $post = substr($::ORIG, $pos, 40);
92+
1 while $post =~ s!(\n.*)!!;
93+
$post = '<EOL>' if $post eq '';
94+
" at " . $::FILE->{'name'} . " line $line:\n------> " . $Cursor::GREEN . $pre . $Cursor::YELLOW . $::PERL6HERE . $Cursor::RED .
95+
"$post$Cursor::CLEAR";
96+
};
97+
## method line
98+
sub line {
99+
no warnings 'recursion';
100+
my $self = shift;
101+
$self->lineof($self->{'_pos'})};
102+
## method lineof ($p)
103+
sub lineof {
104+
no warnings 'recursion';
105+
my $self = shift;
106+
die 'Required argument p omitted' unless @_;
107+
my $p = @_ ? shift() : undef;
108+
return 1 unless defined $p;
109+
my $line = $::MEMOS[$p]->{'L'};
110+
return $line if $line;
111+
$line = 0;
112+
my $pos = 0;
113+
my @text = split(/^/,$::ORIG);
114+
for (@text) {
115+
$line++;
116+
$::MEMOS[$pos++]->{'L'} = $line
117+
for 1 .. length($_);
118+
}
119+
;
120+
$::MEMOS[$pos++]->{'L'} = $line;
121+
return $::MEMOS[$p]->{'L'} // 0;
122+
};
123+
## method SETGOAL
124+
sub SETGOAL {
125+
no warnings 'recursion';
126+
my $self = shift;
127+
};
128+
## method FAILGOAL (Str $stop, Str $name, $startpos)
129+
sub FAILGOAL {
130+
no warnings 'recursion';
131+
my $self = shift;
132+
die 'Required argument stop omitted' unless @_;
133+
my $stop = @_ ? shift() : undef;
134+
die 'Required argument name omitted' unless @_;
135+
my $name = @_ ? shift() : undef;
136+
die 'Required argument startpos omitted' unless @_;
137+
my $startpos = @_ ? shift() : undef;
138+
my $s = "'$stop'";
139+
$s = '"\'"' if $s eq "'''";
140+
$self->panic("Unable to parse $name" . $startpos->locmess . "\nCouldn't find final $s; gave up");
141+
};
142+
1; };

‎Makefile

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -62,7 +62,7 @@ snap: all
6262
$(MV) snap.new snap
6363

6464
snaptest: snap
65-
cd snap && $(PERL) teststd $(realpath ../../t/spec)
65+
cd snap && $(PERL) teststd $(realpath ../roast)
6666

6767
#List all targets with brief descriptions.
6868
# Gradual shaving of targets with Occam's Razor would be a Good Thing.

0 commit comments

Comments
 (0)