Skip to content

Commit 561bda7

Browse files
author
Chris White
committed
Integrated Preparse into Core; updated tests
All tests pass
1 parent b6d1b38 commit 561bda7

File tree

12 files changed

+59
-125
lines changed

12 files changed

+59
-125
lines changed

‎MANIFEST‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,16 @@
11
bin/axk
22
Changes
33
lib/Object/TinyDefaults.pm
4-
lib/XML/Axk.pm
54
lib/XML/Axk/App.pm
65
lib/XML/Axk/Base.pm
76
lib/XML/Axk/Core.pm
87
lib/XML/Axk/DOM.pm
9-
lib/XML/Axk/L0.pm
10-
lib/XML/Axk/L1.pm
8+
lib/XML/Axk/L/L0.pm
9+
lib/XML/Axk/L/L1.pm
1110
lib/XML/Axk/Language.pm
1211
lib/XML/Axk/Matcher/Always.pm
1312
lib/XML/Axk/Matcher/XPath.pm
13+
lib/XML/Axk/Preparse.pm
1414
lib/XML/Axk/Sandbox.pm
1515
lib/XML/Axk/SAX/BuildDOM2.pm
1616
lib/XML/Axk/SAX/Handler.pm
@@ -23,6 +23,7 @@ MANIFEST This list of files
2323
MANIFEST.SKIP
2424
README.md
2525
t/00-load.t
26+
t/01-preparse.t
2627
t/02-basic-app.t
2728
t/02-basic-core.t
2829
t/04-languages.t
@@ -33,6 +34,7 @@ t/ex/1.axk
3334
t/ex/2.axk
3435
t/ex/ex1.xml
3536
t/ex/l0.axk
37+
t/ex/nutrition.xml
3638
t/ex/oneliner
3739
t/ex/xml1.axk
3840
t/lib/AxkTest.pm

‎lib/XML/Axk/Core.pm‎

Lines changed: 13 additions & 96 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,8 @@
88

99
package XML::Axk::Core;
1010
use XML::Axk::Base qw(:all);
11+
use XML::Axk::Preparse;
12+
use Data::Dumper;
1113

1214
=encoding UTF-8
1315
@@ -82,11 +84,7 @@ sub load_script_file {
8284

8385
my $fn = shift;
8486
open(my $fh, '<', $fn) or croak("Cannot open $fn");
85-
my $contents;
86-
{
87-
local $/;
88-
$contents = <$fh>;
89-
}
87+
my $contents = do { local $/; <$fh> };
9088
close $fh;
9189

9290
$self->load_script_text($contents, $fn, false);
@@ -116,104 +114,23 @@ sub load_script_text {
116114
# Text to wrap around the script
117115
my ($leader, $trailer) = ('', '');
118116

119-
# Prep the filename
120-
#$fn =~ s{\\}{\\\\}g; # This doesn't seem to be necessary based on
121-
# the regex given for #line in perlsyn.
122-
$fn =~ s{"}{-}g;
123-
# as far as I can tell, #line can't handle embedded quotes.
124-
125-
my $has_lang;
126-
my $curr_trailer;
127-
my $lines_added = 0;
128-
129-
# TODO replace this with calls to Preparse routines
130-
131-
# Split the file into individual Ln blocks
132-
while( $text =~ m/$RE_Pragma/g ) {
133-
my @idxes=($-[0], $+[0]);
134-
my $lang = $1;
135-
my $oldpos = pos($text);
136-
my $length_delta = 0; # how much to adjust pos($text) by
137-
138-
# Get line number in the present, possibly modified, text
139-
my $curr_lineno = 1 + ( () = substr($text, 0, $idxes[0]) =~ /\n/g );
140-
# Thanks to ikegami, http://www.perlmonks.org/?node_id=968352
141-
$curr_lineno -= $lines_added;
142-
143-
# Ln must be followed by whitespace and a newline.
144-
# This is to keep the line numbering vaguely consistent.
145-
# However, the very last line does not have to end with a newline.
146-
# That makes it easier to use command-line scripts.
147-
my $didremove = (substr($text, $idxes[1]) =~ s/\A(\h*(?:\n|\Z))//);
148-
my $removed = $1;
149-
150-
unless($didremove) {
151-
# Tell the caller where in the source file the problem is
152-
eval "#line $curr_lineno \"$fn\"\n" .
153-
"die(\"L$lang indicator must be on its own line\");";
154-
die $@;
155-
}
156-
157-
$length_delta -= length($removed);
158-
159-
my $replacement = '';
160-
$has_lang = true;
161-
162-
# End an existing capture if we're switching languages
163-
if($curr_trailer) {
164-
$replacement .= "$curr_trailer\n" .
165-
"#line $curr_lineno \"$fn\"\n";
166-
$curr_trailer='';
167-
$lines_added += 2;
168-
}
169-
170-
# Does this language parse the source text itself?
171-
my $want_text;
172-
eval "require XML::Axk::L::L$lang";
173-
die "Can't find language $lang: $@" if $@;
174-
do {
175-
no strict 'refs';
176-
$want_text = ${"XML::Axk::L::L${lang}::C_WANT_TEXT"};
177-
};
178-
179-
unless($want_text) { # Easy case: the script's code is still Perl
180-
$replacement .= "use XML::Axk::L::L$lang;\n";
181-
182-
} else { # Harder case: give the Ln the source text
183-
$curr_trailer =
184-
"AXK_EMBEDDED_SOURCE_DO_NOT_TYPE_THIS_YOURSELF_OR_ELSE";
185-
186-
my $following_lineno = $curr_lineno+1;
187-
# Number of first line of the text in that language
188-
$replacement .=
189-
"use XML::Axk::L::L$lang \"$fn\", $following_lineno, " .
190-
"<<'$curr_trailer';\n";
191-
}
192-
193-
if($replacement) {
194-
substr($text, $idxes[0], $idxes[1] - $idxes[0]) = $replacement;
195-
$length_delta += (length($replacement) - ($idxes[1] - $idxes[0]));
196-
}
197-
198-
if($length_delta) {
199-
#say "pos = $oldpos; Delta pos = $length_delta";
200-
pos($text) = $oldpos + $length_delta;
201-
}
202-
203-
%pragmas = (); # reset for next time through the loop
204-
} #foreach Ln block
205-
206-
$text .= "\n" unless substr($text, length($text)-1) eq "\n";
207-
$text .= "$curr_trailer\n" if $curr_trailer;
117+
my ($lrPieces, $has_lang) = XML::Axk::Preparse::pieces(\$text,
118+
$add_Ln ? { L => {} } : undef);
208119

120+
#say "Has lang" if $has_lang;
209121
unless($has_lang) {
210122
if($add_Ln) {
211-
$leader = "use XML::Axk::L1;\n"; # To be updated over time
123+
$lrPieces->[0]->{pragmas}->{L}->{digits} = 1; # default language
212124
} else {
213-
croak "No language (Ln) specified in file $fn";
125+
die "No language (Ln) specified in file $fn";
214126
}
215127
}
216128

129+
#say Dumper($lrPieces);
130+
my $srNewText = XML::Axk::Preparse::assemble($fn, $lrPieces);
131+
$text = $$srNewText;
132+
133+
$text .= "\n" unless substr($text, length($text)-1) eq "\n";
217134

218135
# Mark the filename for the sake of error messages.
219136
$leader .= ";\n#line 1 \"$fn\"\n";

‎lib/XML/Axk/L/Language.pm‎ renamed to ‎lib/XML/Axk/Language.pm‎

File renamed without changes.

‎lib/XML/Axk/Preparse.pm‎

Lines changed: 26 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@
99
package XML::Axk::Preparse;
1010
use XML::Axk::Base qw(:all);
1111

12-
use Devel::Peek;
12+
use Data::Dumper;
1313

1414
=encoding UTF-8
1515
@@ -53,7 +53,14 @@ files.
5353
5454
Split the given source text into language-specific pieces. Usage:
5555
56-
my $lrPieces = pieces(\$source_text);
56+
my $lrPieces = pieces(\$source_text[, $hrInitialPragmas]);
57+
my ($lrPieces, $hasLang) = pieces(\$source_text[, $hrInitialPragmas]);
58+
59+
In the second form, it also tells you whether any Ln pragma is present
60+
in the source text.
61+
62+
If you specify a C<$hrInitialPragma>, it will govern any lines before the
63+
first pragma in the source text.
5764
5865
=cut
5966

@@ -62,6 +69,7 @@ sub pieces {
6269
croak 'Need a source reference' unless ref $srText eq 'SCALAR';
6370

6471
my @retval;
72+
my $hasLang = false;
6573

6674
# Regex to match a pragma line. A pragma line can include up to two
6775
# -L/-B items, generally one -L and one -B.
@@ -84,7 +92,12 @@ sub pieces {
8492
})){1,2}
8593
}mx;
8694

95+
# Initial pragmas, if any
96+
if(@_) {
97+
push @retval, { text => '', start => 1, pragmas => (shift) };
98+
}
8799

100+
# Main loop
88101
open my $fh, '<', $srText;
89102
while(<$fh>) {
90103

@@ -94,18 +107,21 @@ sub pieces {
94107

95108
$hrPragmas->{name} =~ s/\./::/g if $hrPragmas->{name};
96109
push @retval, { text => '' , start => $.+1, pragmas => $hrPragmas };
110+
$hasLang = true if $hrPragmas->{L};
97111
next;
98112
}
99113

100114
# Otherwise, normal line.
101-
unless(/^\h*(#|$)/) { # Ignore blanks and comments before the
115+
# TODO permit the caller to say what to do with lines before the first pragma
116+
unless(/^\h*(#|$)/) { # Ignore blanks and comments before the
102117
# first Ln.
103118
die "Source text can't come before a pragma line" unless @retval;
104119
}
105120
$retval[-1]->{text} .= $_;
106121
}
107122
close $fh;
108123

124+
return \@retval, $hasLang if wantarray;
109125
return \@retval;
110126
} #pieces()
111127

@@ -133,7 +149,10 @@ sub assemble {
133149
# Which language?
134150
my $lang = ($hrPiece->{pragmas}->{L}->{digits} //
135151
$hrPiece->{pragmas}->{L}->{name});
136-
die "No language recorded!?!?!!??" unless defined $lang;
152+
unless(defined $lang) {
153+
$retval .= $hrPiece->{text};
154+
next;
155+
}
137156
$lang = "XML::Axk::L::L$lang";
138157

139158
# Does this language parse the source text itself?
@@ -158,7 +177,7 @@ sub assemble {
158177
"use $lang \"$filename\", $hrPiece->{start}, " .
159178
"<<'$trailer';\n";
160179
$retval .= $hrPiece->{text};
161-
$retval .= "$trailer\n";
180+
$retval .= "\n$trailer\n";
162181
# Don't need a #line because the next language will take care of it
163182
}
164183
}
@@ -181,8 +200,8 @@ sub preparse {
181200
my $srTextIn = $_[1] or croak('Need text');
182201
$srTextIn = \$_[1] unless ref $srTextIn eq 'SCALAR';
183202

184-
my $hrPieces = pieces($srTextIn);
185-
my $srTextOut = assemble($filename, $hrPieces);
203+
my $lrPieces = pieces($srTextIn);
204+
my $srTextOut = assemble($filename, $lrPieces);
186205
return $srTextOut;
187206
} #preparse()
188207

‎t/02-basic-app.t‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -11,8 +11,6 @@ BEGIN {
1111
use_ok( 'XML::Axk::App' ) || print "Bail out!\n";
1212
}
1313

14-
diag( "Testing XML::Axk::App $XML::Axk::App::VERSION, Perl $], $^X" );
15-
1614
sub localpath {
1715
state $voldir = [File::Spec->splitpath(__FILE__)];
1816
return File::Spec->catpath($voldir->[0], $voldir->[1], shift)

‎t/02-basic-core.t‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -11,8 +11,6 @@ BEGIN {
1111
use_ok( 'XML::Axk::Core' ) || print "Bail out!\n";
1212
}
1313

14-
diag( "Testing XML::Axk::Core $XML::Axk::Core::VERSION, Perl $], $^X" );
15-
1614
sub localpath {
1715
state $voldir = [File::Spec->splitpath(__FILE__)];
1816
return File::Spec->catpath($voldir->[0], $voldir->[1], shift)

‎t/04-languages.t‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -18,23 +18,23 @@ sub localpath {
1818
{
1919
my $out = capture_stdout
2020
{ XML::Axk::App::Main(['--no-input', '-e',
21-
"say __LINE__;\nL1\nL0\nL1\nL0\nL0\nL1\nL1\nsay __LINE__;" ]) };
21+
"say __LINE__;\n-L1\n-L0\n-L1\n-L0\n-L0\n-L1\n-L1\nsay __LINE__;" ]) };
2222
like($out, qr/1\n9\n\Z/, 'line number counting works');
2323
}
2424

2525
# }}}1
2626
# Whitespace on Ln lines ========================================== {{{1
2727
{
2828
my $out = capture_merged
29-
{ XML::Axk::App::Main(['--no-input', '-e', "L1\n L1\nL1 \nL1 " ]) };
29+
{ XML::Axk::App::Main(['--no-input', '-e', "-L1\n-L1\n-L1 \n-L1 \n-L1\t" ]) };
3030
is($out, '', 'whitespace with Ln');
3131
}
3232

3333
# }}}1
3434
# Semicolons and leading zeros on Ln lines ======================== {{{1
3535
{
3636
my $out = capture_merged
37-
{ XML::Axk::App::Main(['--no-input', '-e', "L1;\nL01\nL01;\nL0000" ]) };
37+
{ XML::Axk::App::Main(['--no-input', '-e', "-L1;\n-L01\n-L01;\n-L0000" ]) };
3838
is($out, '', 'semicolons and leading zeros with Ln');
3939
}
4040

‎t/ex/02.axk‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
# 02.axk: used by 02-basic*.t
2-
L1
2+
-L1
33
#use Devel::StackTrace;
44
#say "02.axk:\n", Devel::StackTrace->new->as_string;
55
pre_all { # otherwise it happens during load

‎t/ex/1.axk‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
say "hello from foo!";
2-
L1
2+
-L1
33
#BEGIN { no strict 'refs'; say Dumper(\%{"axk_script_0::"}); };
44

55
pre_all {

‎t/ex/2.axk‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
L1
1+
#!/usr/bin/env axk -L1
22
perform {
33
my $x = $C;
44
chomp $x;

0 commit comments

Comments
 (0)