#!/usr/local/bin/perl -w
require 5.005;
use vars qw( $VERSION $Prefix $Suffix );$VERSION = "1.22";
sub _indent {
join "", map { ref $_ ? _indent(@$_) : $_ } @_
}
sub indent {
my $i = _indent(@_);
$i =~ s/^/ /gm;
$i
}
my %Opts;
GetOptions(\%Opts, "quiet!") or die "bad options";
sub msg {
return if $Opts{quiet};
printf STDERR "%4d,%3d: ", shift, shift;
print STDERR @_, "\n";
return
}
$Prefix = <<'EOH';
#!/usr/local/bin/perl -w
# This program was generated by lines2perl, which is part of Gedcom.pm.
# Gedcom.pm is Copyright 1998-2019, Paul Johnson (paul@pjcj.net)
# Version 1.22 - 15th November 2019
# Gedcom.pm is free. It is licensed under the same terms as Perl itself.
# The latest version of Gedcom.pm should be available from my homepage:
use strict;
require 5.005;
use diagnostics;
use integer;
use Getopt::Long;
use Gedcom::LifeLines 1.22;
my $Ged; # Gedcom object
my %Opts; # options
my $_Traverse_sub; # subroutine for traverse
sub out { print STDERR @_ unless $Opts{quiet} }
sub outf { printf STDERR @_ unless $Opts{quiet} }
sub initialise () {
die "usage: $0 -gedcom_file file.ged\n"
unless GetOptions(\%Opts,
"gedcom_file=s",
"quiet!",
"validate!",
) and defined $Opts{gedcom_file};
local $SIG{__WARN__} = sub { out "\n@_" };
out "reading...";
$Ged = Gedcom->new(
gedcom_file => $Opts{gedcom_file},
callback => sub { out "." }
);
if ($Opts{validate}) {
out "\nvalidating...";
my %x;
my $vcb = sub {
my ($r) = @_;
my $t = $r->{xref};
out "." if $t && !$x{$t}++;
};
$Ged->validate($vcb);
}
out "\n";
set_ged($Ged);
}
$SIG{__WARN__} = sub {
out $_[0] unless $_[0] =~ /^Use of uninitialized value/
};
EOH
$Suffix = <<'EOS';
initialise();
main();
flush();
0
EOS
my $Grammar = <<'EOG';
{ my (%Globals, %Locals, %Params); }
program : declaration(s) /$/s
{ print $::Prefix, join("", @{$item[1]}), $::Suffix }
| <error: column $thiscolumn: bad program>
declaration : //
{ ::msg($thisline, $thiscolumn, "parsing declaration") }
| comment
| procedure_definition
| global_statement
{ "$item[1];\n" }
| list_statement
{ "$item[1];\n" }
| table_statement
{ "$item[1];\n" }
| indiset_statement
{ "$item[1];\n" }
| include_statement
{ "$item[1];\n" }
| <error: column $thiscolumn: bad declaration>
statement : "}" <commit> <reject>
| //
{ ::msg($thisline, $thiscolumn, "parsing statement") }
| comment
| constant
{ "display $item[1];\n" }
| call_statement
{ "display $item[1];\n" }
| builtin_function
{ "display $item[1];\n" }
| emulated_function
{ "display $item[1];\n" }
| builtin_procedure
{ "$item[1];\n" }
| global_statement
{ "$item[1];\n" }
| list_statement
{ "$item[1];\n" }
| table_statement
{ "$item[1];\n" }
| indiset_statement
{ "$item[1];\n" }
| set_statement
{ "$item[1];\n" }
| getintmsg_statement
{ "$item[1];\n" }
| getstrmsg_statement
{ "$item[1];\n" }
| getindimsg_statement
{ "$item[1];\n" }
| continue_statement
{ "$item[1];\n" }
| break_statement
{ "$item[1];\n" }
| return_statement
{ "$item[1];\n" }
| include_statement
{ "$item[1];\n" }
| if_statement
| while_statement
| forlist_statement
| spouses_statement
| families_statement
| forindi_statement
| children_statement
| forfam_statement
| fornodes_statement
| traverse_statement
| forindiset_statement
| non_call_statement
{ "display $item[1];\n" }
| scalar ...!"("
{ "display $item[1];\n" }
| <uncommit> <error: column $thiscolumn: bad statement>
statements : ..."}"
{ [] }
| statement statements
{ [$item[1], @{$item[2]}] }
expression : ")" <commit> <reject>
| //
{ ::msg($thisline, $thiscolumn, "parsing expression") }
| constant
| call_statement
| builtin_function
| emulated_function
| non_call_statement
| "(" ")"
{ "" }
| "(" expression ")"
{ "($item[2])" }
| scalar ...!"("
{ $item[1] }
| <uncommit> <error: column $thiscolumn: bad expression>
procedure_definition : ("proc" | "func") name "(" scalars(?) ")"
"{" statements "}"
{
# warn "item is ", ::Dumper \@item;
my $args = @{$item[4]} ? $item[4][0] =~ tr/$/$/ : 0;
my $val =
"sub $item[2] (" . '$' x $args . ")\n" .
"{\n" .
($args
? (" my($item[4][0]) = \@_;\n")
: "") .
join("", map { qq( my \$$_;\n) }
sort keys %Locals) .
::indent($item[7]) .
($item[1] eq "proc" ? " undef\n" : "") .
"}\n\n";
%Locals = %Params = ();
$val
}
comment : /\s*\/\*.*?\*\/\s*/s
{
my $comment = $item[1];
$comment =~ s/\n+$//;
$comment =~ s/^/# /gm;
$comment . "\n"
}
block : comment(s?) "{" statements "}" comment(s?)
{
"@{$item[1]}" .
"{\n" .
::indent($item[3]) .
"}\n@{$item[5]}"
}
condition_and_block : "(" scalar_assignment(?) expression ")" block
{
# warn "item is ", ::Dumper \@item;
"(@{$item[2]}$item[3])\n$item[5]"
}
if_statement : "if" condition_and_block
elsif_statement(s?)
else_statement(?)
{
# warn "item is ", ::Dumper \@item;
# local $"; # this line breaks the parser...
"if $item[2]" . join "", @{$item[3]}, @{$item[4]}
}
elsif_statement : "elsif" condition_and_block
{
# warn "item is ", ::Dumper \@item;
"elsif $item[2]"
}
else_statement : "else" block
{
# warn "item is ", ::Dumper \@item;
"else\n$item[2]"
}
while_statement : "while" condition_and_block
{
# warn "item is ", ::Dumper \@item;
"LOOP: while $item[2]"
}
forlist_statement : "forlist" "(" name "," scalar "," scalar ")"
"{" statements "}"
{
# warn "item is ", ::Dumper \@item;
"$item[7] = 0;\n" .
"LOOP: for $item[5] (\@\$$item[3])\n" .
"{\n" .
" $item[7]++;\n" .
::indent($item[10]) .
"}\n"
}
spouses_statement : "spouses" "(" expression ","
scalar "," scalar "," scalar ")" "{" statements "}"
{
# warn "item is ", ::Dumper \@item;
"$item[9] = 0;\n" .
"LOOP: for $item[7] ($item[3]" . "->fams)\n" .
"{\n" .
" for $item[5] ($item[7]" . "->parents)\n" .
" {\n" .
" next if $item[5]" . "->xref eq " .
"$item[3]" . "->xref;\n" .
" $item[9]++;\n" .
::indent(::indent($item[12])) .
" }\n" .
"}\n"
}
families_statement : "families"
"(" expression "," scalar "," scalar "," scalar ")"
"{" statements "}"
{
# warn "item is ", ::Dumper \@item;
"$item[9] = 0;\n" .
"LOOP: for $item[5] ($item[3]" . "->fams)\n" .
"{\n" .
" for $item[7] ($item[5]" . "->parents || undef)\n" .
" {\n" .
" next if $item[7] && $item[7]" . "->xref eq " .
"$item[3]" . "->xref;\n" .
" $item[9]++;\n" .
::indent(::indent($item[12])) .
" }\n" .
"}\n"
}
forindi_statement : "forindi" "(" scalar "," scalar ")"
"{" statements "}"
{
# warn "item is ", ::Dumper \@item;
"$item[5] = 0;\n" .
"LOOP: for $item[3] (\$Ged" . "->individuals)\n" .
"{\n" .
" $item[5]++;\n" .
::indent($item[8]) .
"}\n"
}
children_statement : "children" "(" expression "," scalar "," scalar ")"
"{" statements "}"
{
# warn "item is ", ::Dumper \@item;
"$item[7] = 0;\n" .
"LOOP: for $item[5] ( " .
"do { my \$e = $item[3]; \$e ? \$e->children : ()} )\n" .
"{\n" .
" $item[7]++;\n" .
::indent(::indent($item[10])) .
"}\n"
}
forfam_statement : "forfam" "(" scalar "," scalar ")"
"{" statements "}"
{
# warn "item is ", ::Dumper \@item;
"$item[5] = 0;\n" .
"LOOP: for $item[3] (\$Ged" . "->families)\n" .
"{\n" .
" $item[5]++;\n" .
::indent($item[8]) .
"}\n"
}
fornodes_statement : "fornodes" "(" expression "," scalar ")"
"{" statements "}"
{
# warn "item is ", ::Dumper \@item;
"LOOP: for $item[5] (\@{$item[3]" . "->_items})\n" .
"{\n" .
::indent($item[8]) .
"}\n"
}
traverse_statement : "traverse" "(" expression "," scalar "," scalar ")"
"{" statements "}"
{
# warn "item is ", ::Dumper \@item;
"\$_Traverse_sub = sub\n" .
"{\n" .
" my (\$_traverse_sub_node, " .
"\$_traverse_sub_level) = \@_;\n" .
" $item[5] = \$_traverse_sub_node;\n" .
" $item[7] = \$_traverse_sub_level;\n" .
::indent($item[10]) .
" LOOP: for my \$_traverse_sub_item " .
"(\@{\$_traverse_sub_node" . "->_items})\n" .
" {\n" .
" \$_Traverse_sub->(\$_traverse_sub_item, " .
"\$_traverse_sub_level + 1)\n" .
" }\n" .
"};\n" .
"\$_Traverse_sub->($item[3], 0);\n"
}
forindiset_statement : "forindiset"
"(" scalar "," scalar "," scalar "," scalar ")"
"{" statements "}"
{
# warn "item is ", ::Dumper \@item;
"$item[9] = 0;\n" .
"LOOP: for (\@{" . "$item[3]})\n" .
"{\n" .
" ($item[5], $item[7]) = \@\$_;\n" .
" $item[9]++;\n" .
::indent($item[12]) .
"}\n"
}
scalar_assignment : scalar ","
{ "$item[1] = " }
include_statement : "include" "(" expression ")"
{ "do $item[3]" }
global_statement : "global" "(" name ")"
{ $Globals{$item[3]}++; qq(my \$$item[3]) }
set_statement : "set" "(" scalar "," expression ")"
{ "$item[3] = $item[5]" }
getintmsg_statement : "getintmsg" "(" scalar "," expression ")"
{
::msg($prevline, $prevcolumn,
qq(warning: $item[1] needs to be replaced));
"$item[3] = $item[5]"
}
getstrmsg_statement : "getstrmsg" "(" scalar "," expression ")"
{
::msg($prevline, $prevcolumn,
qq(warning: $item[1] needs to be replaced));
"$item[3] = $item[5]"
}
getindimsg_statement : "getindimsg" "(" scalar "," expression ")"
{
::msg($prevline, $prevcolumn,
qq(warning: $item[1] needs to be replaced));
"$item[3] = $item[5]"
}
continue_statement : "continue" "(" ")"
{ "next LOOP" }
break_statement : "break" "(" ")"
{ "last LOOP" }
return_statement : "return" expression(?)
{ "return" . (@{$item[2]} ? " @{$item[2]}" : "") }
list_statement : "list" "(" name ")"
{
my $s = $item[3];
$Locals{$s}++
unless exists $Globals{$s} || exists $Params{$s};
"\$$s = []"
}
table_statement : "table" "(" name ")"
{
my $s = $item[3];
$Locals{$s}++
unless exists $Globals{$s} || exists $Params{$s};
"\$$s = {}"
}
indiset_statement : "indiset" "(" name ")"
{
my $s = $item[3];
$Locals{$s}++
unless exists $Globals{$s} || exists $Params{$s};
"\$$s = []"
}
name : /(?!\d)\w+/
scalar : name
{
my $s = $item[1];
$Locals{$s}++
unless exists $Globals{$s} || exists $Params{$s};
"\$$s"
}
scalars : name ("," name)(s?)
{
$Params{$_}++ for ($item[1], @{$item[2]});
'$' . join ', $', $item[1], @{$item[2]}
}
#scalars : scalar ("," scalar)(s?)
# {
# # $Params{$_}++ for ($item[1], @{$item[2]);
# join ', ', $item[1], @{$item[2]}
# }
expressions : expression ("," expression)(s?)
{ [$item[1], @{$item[2]}] }
expressions2 : expression ("," expression)(s)
{ [$item[1], @{$item[2]}] }
_call_statement : name "(" expressions(?) ")" ...!"{"
{
"&$item[1](" . join(", ", map {@$_} @{$item[3]}) . ")"
}
non_call_statement : _call_statement
{
::msg($prevline, $prevcolumn,
qq(warning: $item[1] called without "call"));
$item[1]
}
call_statement : "call" _call_statement
builtin_function : add_function
| sub_function
| mul_function
| div_function
| mod_function
| exp_function
| neg_function
| and_function
| or_function
| not_function
| eq_function
| eqstr_function
| ne_function
| nestr_function
| lt_function
| le_function
| gt_function
| ge_function
| empty_function
| length_function
| dequeue_function
| pop_function
| getel_function
| lookup_function
builtin_procedure : incr_procedure
| decr_procedure
| enqueue_procedure
| requeue_procedure
| push_procedure
| setel_procedure
| insert_procedure
add_function : "add" "(" expressions2 ")"
{ "(" . join(" + ", @{$item[3]}) . ")" }
sub_function : "sub" "(" expression "," expression ")"
{ "($item[3] - $item[5])" }
mul_function : "mul" "(" expressions2 ")"
{ "(" . join(" * ", @{$item[3]}) . ")" }
div_function : "div" "(" expression "," expression ")"
{ "($item[3] / $item[5])" }
mod_function : "mod" "(" expression "," expression ")"
{ "($item[3] % $item[5])" }
exp_function : "exp" "(" expression "," expression ")"
{ "($item[3] ** $item[5])" }
neg_function : "neg" "(" expression ")"
{ "(- $item[3])" }
and_function : "and" "(" expressions2 ")"
{ "(" . join(" && ", @{$item[3]}) . ")" }
or_function : "or" "(" expressions2 ")"
{ "(" . join(" || ", @{$item[3]}) . ")" }
not_function : "not" "(" expression ")"
{ "(! $item[3])" }
eq_function : "eq" "(" expression "," expression ")"
{ "($item[3] == $item[5])" }
ne_function : "ne" "(" expression "," expression ")"
{ "($item[3] != $item[5])" }
eqstr_function : "eqstr" "(" expression "," expression ")"
{ "($item[3] eq $item[5])" }
nestr_function : "nestr" "(" expression "," expression ")"
{ "($item[3] ne $item[5])" }
lt_function : "lt" "(" expression "," expression ")"
{ "($item[3] < $item[5])" }
le_function : "le" "(" expression "," expression ")"
{ "($item[3] <= $item[5])" }
gt_function : "gt" "(" expression "," expression ")"
{ "($item[3] > $item[5])" }
ge_function : "ge" "(" expression "," expression ")"
{ "($item[3] >= $item[5])" }
empty_function : "empty" "(" name ")"
{ "(\@\$$item[3] ? 0 : 1)" }
length_function : "length" "(" name ")"
{ "(scalar \@\$$item[3])" }
dequeue_function : "dequeue" "(" name ")"
{ "(shift \@\$$item[3])" }
pop_function : "pop" "(" name ")"
{ "(pop \@\$$item[3])" }
getel_function : "getel" "(" name "," expression ")"
{ "\$$item[3]" . "->[$item[5] - 1]" }
lookup_function : "lookup" "(" name "," expression ")"
{ "\$$item[3]" . "->{$item[5]}" }
emulated_function : emulated_name "(" expressions(?) ")"
{
# warn "item is ", ::Dumper \@item;
"&$item[1](" . join(", ", map {@$_} @{$item[3]}) . ")"
}
incr_procedure : "incr" "(" scalar ")"
{ "$item[3]++" }
decr_procedure : "decr" "(" scalar ")"
{ "$item[3]--" }
enqueue_procedure : "enqueue" "(" name "," expression ")"
{ "push \@\$$item[3], $item[5]" }
requeue_procedure : "requeue" "(" name "," expression ")"
{ "unshift \@\$$item[3], $item[5]" }
push_procedure : "push" "(" name "," expression ")"
{ "push \@\$$item[3], $item[5]" }
setel_procedure : "setel" "(" name "," expression "," expression ")"
{ "\$$item[3]" . "->[$item[5] - 1] = $item[7]" }
insert_procedure : "insert" "(" name "," expression "," expression ")"
{ "\$$item[3]" . "->{$item[5]} = $item[7]" }
constant : /([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?/
| /".*?(?<!\\)"/
| /'.*?(?<!\\)'/
EOG
my @keywords = (
@Gedcom::LifeLines::EXPORT, qw (
proc
func
if
elsif
else
while
forlist
spouses
families
forindi
children
forfam
fornodes
traverse
include
global
set
getintmsg
getstrmsg
getindimsg
continue
break
return
list
table
call
add
sub
mul
div
mod
exp
neg
and
or
not
eq
ne
lt
le
gt
ge
empty
length
dequeue
pop
getel
lookup
incr
decr
enqueue
requeue
push
setel
insert
)
);
my $x = "emulated_name : /\\b(" . join("|", @Gedcom::LifeLines::EXPORT) .
")\\b/\n" .
"";
$::RD_HINT = 1;
my $parse = Parse::RecDescent->new($Grammar . $x);
undef $/;
my $input = <>;
$parse->program($input) or die "invalid input";
print <<EOO