1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
package TestDevelPegex;
use strict; use warnings;
use File::Spec;
use Test::More;
use IO::All;
use Time::HiRes qw(gettimeofday tv_interval);
my $time;
use base 'Exporter';
our @EXPORT = qw(
pegex_parser
pegex_parser_ast
slurp
test_grammar_paths
gettimeofday
tv_interval
XXX
);
use constant TEST_GRAMMARS => [
'../pegex-pgx/pegex.pgx',
'../testml-pgx/testml.pgx',
'../json-pgx/json.pgx',
'../yaml-pgx/yaml.pgx',
'../kwim-pgx/kwim.pgx',
'../drinkup/share/drinkup.pgx',
# '../SQL-Parser-Neo/pegex/pg-lexer.pgx',
'../SQL-Parser-Neo/pegex/Pg.pgx',
];
sub pegex_parser {
require Pegex::Parser;
require Pegex::Pegex::Grammar;
require Pegex::Tree::Wrap;
my ($grammar) = @_;
return Pegex::Parser->new(
grammar => Pegex::Pegex::Grammar->new,
receiver => Pegex::Tree::Wrap->new,
);
}
sub pegex_parser_ast {
require Pegex::Parser;
require Pegex::Pegex::Grammar;
require Pegex::Pegex::AST;
my ($grammar) = @_;
return Pegex::Parser->new(
grammar => Pegex::Pegex::Grammar->new,
receiver => Pegex::Pegex::AST->new,
);
}
sub slurp {
my ($path) = @_;
return scalar io->file($path)->all;
}
sub test_grammar_paths {
my @paths;
for my $grammar_source (@{TEST_GRAMMARS()}) {
my $grammar_file = check_grammar($grammar_source)
or next;
push @paths, $grammar_file;
}
return @paths;
}
#-----------------------------------------------------------------------------#
sub check_grammar {
my ($source) = @_;
(my $file = $source) =~ s!.*/!!;
my $xt = -e 'xt' ? 'xt' : File::Spec->catfile('test', 'devel');
my $path = File::Spec->catfile('.', $xt, 'grammars', $file);
if (-e $source) {
if (not -e $path) {
diag "$path not found. Copying from $source\n";
copy_grammar($source, $path);
}
elsif (slurp($source) ne slurp($path)) {
diag "$path is out of date. Copying from $source\n";
copy_grammar($source, $path);
}
}
return -e $path ? $path : undef;
}
sub copy_grammar {
my ($source, $target) = @_;
return unless -e $source;
io->file($target)->assert->print(slurp($source));
}
END {
done_testing;
}
1;
|
