view release on metacpan or  search on metacpan

lib/Gedcom.pm  view on Meta::CPAN

    # TODO - find a way to do this nicely for different grammars
    $self->{types}{INDI} = "Individual";
    $self->{types}{FAM}  = "Family";
    $self->{types}{$_}   = "Event" for qw(
        ADOP ANUL BAPM BARM BASM BIRT BLES BURI CAST CENS CENS CHR CHRA CONF
        CREM DEAT DIV DIVF DSCR EDUC EMIG ENGA EVEN EVEN FCOM GRAD IDNO IMMI
        MARB MARC MARL MARR MARS NATI NATU NCHI NMR OCCU ORDN PROB PROP RELI
        RESI RETI SSN WILL
    );
    bless $self, $class;

    # first read in the grammar
    my $grammar;
    if (defined $self->{grammar_file}) {
        my $version;
        if (defined $self->{grammar_version}) {
            $version = $self->{grammar_version};
        } else {
            ($version) = $self->{grammar_file} =~ /(\d+(\.\d+)*)/;
        }
        die "version must be a GEDCOM version number\n" unless $version;
        return undef unless
        $grammar = Gedcom::Grammar->new(
            file     => $self->{grammar_file},
            version  => $version,
            callback => $self->{callback}
        );
    } else {
        $self->{grammar_version} = 5.5 unless defined $self->{grammar_version};
        (my $v = $self->{grammar_version}) =~ tr/./_/;
        my $g = "Gedcom::Grammar_$v";
        eval "use $g $VERSION";
        die $@ if $@;
        no strict "refs";
        return undef unless $grammar = ${$g . "::grammar"};
    }
    my @c = ($self->{grammar} = $grammar);
    while (@c) {
        @c = map { $_->{top} = $grammar; @{$_->{items}} } @c;
    }

    # now read in or create the GEDCOM file
    return undef unless
    my $r = $self->{record} = Gedcom::Record->new(
        defined $self->{gedcom_file} ? (file => $self->{gedcom_file}) : (),
        line     => 0,
        tag      => "GEDCOM",
        grammar  => $grammar->structure("GEDCOM"),
        gedcom   => $self,
        callback => $self->{callback},
    );

    unless (defined $self->{gedcom_file}) {

    # Add the required elements, unless they are already there.

        unless ($r->get_record("head")) {
            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 ($l0, $l1, $l2, $l3);
            $l0 = $self->add_header;
                $l1 = $l0->add("SOUR", "Gedcom.pm");
                $l1->add("NAME", "Gedcom.pm");
                $l1->add("VERS", $VERSION);
                    $l2 = $l1->add("CORP", "Paul Johnson");
                    $l2->add("ADDR", "http://www.pjcj.net");
                    $l2 = $l1->add("DATA");
                        $l3 = $l2->add(
                            "COPR",
                            'Copyright 1998-2019, Paul Johnson (paul@pjcj.net)'
                        );
                $l1 = $l0->add("NOTE", "");
                for (split /\n/, <<'EOH')
This output was generated by 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:
http://www.pjcj.net
EOH
                {
                    $l1->add("CONT", $_);
                };
                $l1 = $l0->add("GEDC");
                $l1->add("VERS", $self->{grammar}{version});
                $l1->add("FORM", "LINEAGE-LINKED");
            $l0->add("DATE", $date);
            $l0->add("CHAR", uc ($self->{encoding} || "ansel"));
            my $s = $r->get_record("subm");
            unless ($s) {
                $s = $self->add_submitter;
                $s->add("NAME", $me);
            }
            $l0->add("SUBM", $s->xref);
        }

        $self->add_trailer unless $r->get_record("trlr");
    }

    $self->collect_xrefs;

    $self
}

sub set_encoding {
    my $self = shift;
    ($self->{encoding}) = @_;
}

sub write {