parse_grammar

#!/usr/local/bin/perl -w

# Copyright 1998-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 Data::Dumper;

use Gedcom;

use vars qw( $VERSION );
$VERSION = "1.16";

$SIG{__WARN__} = sub { print "\n@_" };

sub main()
{
  die "usage: $0 grammar_file [version]\n" unless @ARGV == 1 || @ARGV == 2;
  my ($grammar_file, $version) = @ARGV;
  ($version) = $grammar_file =~ /(\d+(\.\d+)*)/ unless defined $version;
  die "version must be a gedcom version number\n" unless $version;
  $| = 1;
  print "reading $grammar_file ...";
  my $grammar = Gedcom::Grammar->new(file     => $grammar_file,
                                     version  => $version,
                                     callback => sub { print "." });

  delete $grammar->{callback};
  delete $grammar->{stored_record};

  my $me = "Unknown user";
  my $login = $me;
  if ($login = getlogin || (getpwuid($<))[0] || $ENV{USER} || $ENV{LOGIN})
  {
    my $name;
    eval { $name = (getpwnam($login))[6] };
    $me = $name || $login;
  }
  my $date = localtime;

  (my $v = $version) =~ tr/./_/;
  my $g   = "Grammar_$v";
  my $gpm = "lib/Gedcom/$g.pm";
  print "\nwriting $gpm ...\n";
  open(G, ">$gpm") or die "Can't open $gpm: $!";

  print G <<EOT;
# Copyright 1998-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

# This file was automatically generated from $grammar_file
# by $me
# on $date

# Do not edit this file.
# Edit $grammar_file if changes need to be made.
# Edit parse_grammar or Makefile.PL to increase the legibility of this file.
# (Removal of the leading spaces nearly halves the size of the file.)

# Version $VERSION - $date

use strict;

require 5.005;

package Gedcom::$g;

use vars qw(\$VERSION \$grammar);
\$VERSION = $VERSION;

EOT

  my $d = Data::Dumper->new([$grammar], ["grammar"]);
  $d->Indent(1)->Purity(1)->Quotekeys(0);
  my $dv = eval $Data::Dumper::VERSION;
  $d->Sortkeys(1) if $dv >= 2.12;
  $d->Useperl(1)  if $dv >= 2.12;         # Because of a bug.
  print G $d->Dump;
  close G or die "Can't open $gpm: $!";
}

main;