#!/usr/local/bin/perl -w
# Copyright 1999-2009, Paul Johnson (paul@pjcj.net)
# This software is free. It is licensed under the same terms as Perl itself.
# The latest version of this software should be available from my homepage:
# http://www.pjcj.net
# Version 1.16 - 24th April 2009
use strict;
require 5.005;
use diagnostics;
use Data::Dumper;
use Getopt::Long;
use FindBin;
use lib $FindBin::Bin;
use Parse::RecDescent;
use Gedcom 1.16;
use Gedcom::LifeLines 1.16;
use vars qw( $VERSION $Prefix $Suffix );
$VERSION = "1.16";
sub _indent
{
join "", map { ref $_ ? _indent(@$_) : $_ } @_
}
sub indent
{
# print STDERR "indenting @_\n";
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
}
# TODO - use correct perl
$Prefix = <<'EOH';
#!/usr/local/bin/perl -w
# This program was generated by lines2perl, which is part of Gedcom.pm.
# Gedcom.pm is Copyright 1999-2009, Paul Johnson (paul@pjcj.net)
# Version 1.16 - 24th April 2009
# 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:
# http://www.pjcj.net
use strict;
require 5.005;
use diagnostics;
use integer;
use Getopt::Long;
use Gedcom::LifeLines 1.16;
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" .
# '{ $item[1] }' . "\n" .
# "keyword : /\\b(" . join("|", @keywords) . ")\\b/\n" .
"";
# "name : ...!keyword /(?!\\d)\\w+/\n" .
# "name : /(?!\\d)\\w+/\n" .
# "scalar : name\n" .
# '{ "\$$item[1]" }';
# $::RD_TRACE = 1;
$::RD_HINT = 1;
my $parse = Parse::RecDescent->new($Grammar . $x);
undef $/;
my $input = <>;
# print STDERR "input is $input";
$parse->program($input) or die "invalid input";
print <<EOO
__END__
Original LifeLines program follows:
$input
EOO