Gedcom
view release on metacpan or search on metacpan
}
$Top->bind("all", "<Delete>", "Backspace");
create_windows();
load(shift @ARGV); # if @ARGV;
MainLoop;
}
sub load($)
{
my ($gedcom_file) = @_;
$Top->Busy;
my $cont = 1;
my $progress;
$progress = $Top->WaitBox(-title => "Reading...",
-txt1 => "",
-canceltext => "Cancel",
-cancelroutine => sub { $cont = 0 });
my $u = $progress->{SubWidget}{uframe};
my $utxt;
my @pk = (-expand => 1, -fill => "both");
$u->pack(@pk);
$u->Label(-textvariable => \$utxt)->pack(@pk);
my $width = 700;
my $height = 25;
my $canv = $u->Canvas(-width => $width,
-height => $height,
-background => "red")
->pack(-expand => 0);
$progress->Show;
$Top->update;
$Ged = Gedcom->new( # grammar_file => $Grammar_file,
gedcom_file => $gedcom_file,
callback => sub
{
my ($title, $txt1, $txt2, $current, $total) = @_;
if ($total)
{
my $ratio = $current / $total;
$utxt = sprintf("%5.2f%% complete", $ratio * 100);
$canv->delete("all");
$canv->createLine(0, $height / 2, $ratio * $width, $height / 2,
-width => $height,
-fill => "green");
}
$progress->configure(-title => $title,
-txt1 => $txt1,
-txt2 => $txt2);
$Top->update;
$progress->unShow
unless $cont ||= (box("No", "Do you really want to cancel?",
-title => "Cancel",
-buttons => ["Yes", "No"]) eq "No");
$cont;
});
$progress->unShow if $cont;
my @individuals = $Ged->{record}->get_children("INDI");
if (@individuals)
{
show_record("", $individuals[0], "full");
}
$Top->Unbusy;
}
sub save($)
{
my ($gedcom_file) = @_;
$Top->Busy;
$Top->update;
$Ged->write($gedcom_file);
$Top->Unbusy;
}
sub updown($$)
{
my ($list, $pos) = @_;
$list->activate($pos =~ /^[+-]\d+$/ ? $list->index("active") + $pos : $pos);
$list->see("active");
$list->selectionClear(0, "end");
$list->selectionSet("active")
}
sub select_record($)
{
my ($type) = @_;
return undef unless $Ged->{record};
$Top->Busy;
my @records = $Ged->{record}->get_children($type);
# print "records are ", Dumper \@records;
unless (exists $Top->{_box})
{
my $box = $Top->{_box} =
$Top->DialogBox(-default_button => "Ok",
-title => "Select",
-buttons => [ "Ok", "Cancel" ]);
my $frame = $box->add("Frame")->pack(-fill => "both", -expand => 1);
my $list = $frame->Scrolled("Listbox",
-scrollbars => "w")
->pack(-fill => "both", -expand => 1);
my $listbox = $Top->{_list} = $list->Subwidget("listbox");
my %font_spec =
(
family => "courier",
weight => "bold",
slant => "r",
point => $Options{font_point} * .75,
);
my $font = $Top->Font(%font_spec);
confess "Cannot allocate font - try changing some parameters" unless $font;
$listbox->configure(-font => $font,
-width => 65,
-height => 20);
$box->bind("<Double-Button-1>" =>
sub { $box->{selected_button} = $listbox->curselection });
}
$Top->{_list}->delete(0, "end");
for my $i (@records)
{
$Top->{_list}->insert("end", $i->summary)
}
updown($Top->{_list}, "+0");
$Top->Unbusy;
my $i = $Top->{_box}->Show;
return undef if $i eq "Cancel";
$i = $Top->{_list}->curselection if $i eq "Ok";
$records[$i];
}
# TODO - put in Gedcom.pm
sub get_tag($)
{
my ($tag) = @_;
return $tag unless my ($t, $n) = $tag =~ /^([A-z]+)(\d*)$/;
# print "Checking tag for <$t> <$n> => <$Tags{$t}>\n";
my $r = (exists($Tags{$t}) ? $Tags{$t} : $t) . $n;
# print "got <$r>\n";
$r;
}
# TODO - put in Gedcom.pm
sub get_name($)
{
my ($tag) = @_;
# print "tag for $tag\n";
join(" ", map { get_tag($_) } split(/_/, $tag));
}
sub create_items(%)
{
my (%a) = @_;
my $height = $a{height} || 40;
# print "lines is $a{canv}{_lines}\n";
my $y = $a{canv}{_lines}++ * ($height * 1.1);
my $width = 850;
$a{canv}->configure(-scrollregion => [0, 0, $width, $y + $height]);
# print "size is ($width, $y + $height)\n";
my $x = 0;
for my $item (@{$a{items}})
{
my $tag = $item->{tag};
warn "no record for $tag"
unless exists $a{canv}->{_ged}{$tag};
my $rec = $a{canv}->{_ged}{$tag};
if (exists $item->{widget})
{
my $widget= $rec->{"_Frame"} =
$a{canv}->Frame(-width => $width * $item->{relwidth},
-height => $height);
my $w = $item->{widget};
my $bind = $rec->{"_$w"} = $widget->$w(%{$item->{options}})
->pack(-expand => 1, -fill => "both");
$a{canv}->createWindow($width * $x, $y,
-width => $width * $item->{relwidth},
-height => $height,
-tags => [ $tag ],
-anchor => "nw", -window => $widget);
while (exists $item->{"bind"} && @{$item->{"bind"}})
{
}
}
};
my $rsave = sub
{
save_changes("no_ask");
record_changed();
};
my $fselect = sub
{
save_changes();
show_record("", select_record("FAM"), "full");
};
my $file_menu = $Top->{_file_menu} =
$menu_fr->Menubutton(-text => "File", -underline => 0)
->pack(-side => "left");
$file_menu->command(-label => "Load", -underline => 0, -command => $load);
$Top->bind("<Alt-l>", $load);
$file_menu->command(-label => "Save", -underline => 2, -command => $save);
$Top->bind("<Alt-v>", $save);
$file_menu->command(-label => "Quit", -underline => 0, -command => $quit);
$Top->bind("<Alt-q>", $quit);
my $ind_menu = $Top->{_ind_menu} =
$menu_fr->Menubutton(-text => "Individual", -underline => 0)
->pack(-side => "left");
$ind_menu->command(-label => "Select", -underline => 0, -command => $iselect);
$Top->bind("<Alt-e>", $iselect);
$ind_menu->command(-label => "New", -underline => 0, -command => $inew);
$Top->bind("<Alt-n>", $inew);
$ind_menu->command(-label => "Save", -underline => 2, -command => $rsave);
$Top->bind("<Alt-v>", $rsave);
$ind_menu->command(-label => "Delete", -underline => 0, -command => $idelete);
$Top->bind("<Alt-d>", $rsave);
my $fam_menu = $Top->{_fam_menu} =
$menu_fr->Menubutton(-text => "Family", -underline => 5)
->pack(-side => "left");
$fam_menu->command(-label => "Select", -underline => 0, -command => $fselect);
$Top->bind("<Alt-c>", $fselect);
$fam_menu->command(-label => "Save", -underline => 2, -command => $rsave);
# $Top->bind("<Button>" => sub { shift->afterIdle(sub { record_changed() }) });
$Top->bind("<Key>" => sub
{
my $w = shift;
my $ev = $w->XEvent;
# print "Pressed ", $ev->K, "\n";
$w->afterIdle(sub { record_changed() });
});
my $c = $Top->{_canv_frame} =
$main_fr->Scrolled("Canvas", -scrollbars => "osoe")
->pack(-fill => "both", -expand => 1);
my $canv = $Top->{_canv} = $c->Subwidget("scrolled");
$Top->Unbusy;
}
sub set_entry($)
{
my ($entry) = @_;
# print "entry $entry\n";
my $t = $Top->{_canv}{_ged}{$entry};
if (exists $t->{_Entry} && $t->{_Entry}->Exists)
{
my $val = $t->{value} || $t->{xref};
$t->{_Entry}->delete(0, "end");
$t->{_Entry}->insert(0, $val) if $val;
}
}
sub set_entries()
{
for my $t (keys %{$Top->{_canv}->{_ged}})
{
set_entry($t);
}
}
sub record_changed()
{
my $changed = 0;
for my $tag (sort keys %{$Top->{_canv}{_ged}})
{
my $t = $Top->{_canv}{_ged}{$tag};
# print "checking $tag as ", Dumper $t;
if (exists $t->{_Entry} && $t->{_Entry}->Exists)
{
my $val = "";
$val = $t->{xref} if exists $t->{xref};
$val = $t->{value} if (!$val && exists $t->{value});
warn "no val for $tag" unless $val;
$val = "" unless $val;
my $c = $t->{_Entry}->Exists && $t->{_Entry}->get ne $val;
$changed |= $c;
$t->{_Entry}->configure(-fg => $c ? "red" : $Colour_scheme{foreground})
if $t->{_Entry}->Exists;
# print " entry ", $c ? "changed" : "same";
}
elsif (exists $t->{_canvas_text} and
my ($fam, $person) = $tag =~ /^(_FAM[CS]\d*)_([^_]+)_XREF1$/)
{
# print "getting $fam $person from $tag with $t->{_canvas_text}\n";
my $me = $Top->{_canv}{_ged}{_XREF1}{xref};
# print "me is $me\n";
my $id = $Ged->{xrefs}{$me}->child_value($fam);
# print "$fam id is $id\n";
my $family = $Ged->{xrefs}{$id};
# print "family is ", Dumper $family;
my $pers = $family->get_child($person);
(my $item_tag = $t->{_canvas_text}) =~ s/value/XREF1_change/;
my $pid = $Top->{_canv}->itemcget($item_tag, "-text");
if ($pid)
{
my $nid = $pid;
# print "changing from $pers->{value} to $nid\n";
my $ind = $g->{_XREF1};
for my $tag (sort keys %{$g})
{
# print "tag $tag\n";
my $t = $g->{$tag};
if (exists $t->{_Entry} && $t->{_Entry}->Exists)
{
# print "checking entry for $tag ", Dumper $t;;
if (exists $t->{value})
{
my ($v, $g) = ($t->{value}, $t->{_Entry}->get);
if ($v ne $g)
{
$t->{value} = $g;
# print "$tag value <$v> -> <$g> ", Dumper $t;
}
}
elsif (exists $t->{xref})
{
$t->{xref} = $t->{_Entry}->get;
}
else
{
confess "What do I set it to?";
}
}
elsif (exists $t->{_canvas_text} and
my ($fam, $person) = $tag =~ /^(_FAM[CS]\d*)_([^_]+)_XREF1$/)
{
# print "getting $fam $person from $tag\n";
my $me = $Top->{_canv}{_ged}{_XREF1}{xref};
# print "me is $me\n";
my $id = $Ged->{xrefs}{$me}->child_value($fam);
# print "$fam id is $id\n";
my $family = $Ged->{xrefs}{$id};
# print "family is ", Dumper $family;
my $pers = $family->get_child($person);
(my $item_tag = $t->{_canvas_text}) =~ s/value/XREF1_change/;
my $nid = $Top->{_canv}->itemcget($item_tag, "-text");
# print "changing from $pers->{value} to $nid\n";
my $xref = $nid;
if ($pers->{value} ne $xref)
{
$pers->{value} = $xref;
# now we need to point the new person at the appropriate family
my $new = $Ged->{xrefs}{$pers->{value}};
my $fam_tag = add_record($new, $fam);
# print "fam_tag is $fam_tag xref $family->{xref}\n";
$new->get_child($fam_tag)->{value} = $family->{xref};
# print "new is ", Dumper $new;
}
}
}
$Ged->collect_xrefs();
}
}
$Top->Unbusy;
}
sub has_entry($)
{
my ($tag) = @_;
exists $Top->{_canv}{_ged}{$tag}{_Entry} &&
$Top->{_canv}{_ged}{$tag}{_Entry}->Exists;
}
sub add_record($$)
{
my ($ind, $tag) = @_;
my @tags = $tag =~ /_([^_\d]+)(\d*)/g;
# print "Tags are ", join(",", @tags), "\n";
my $rec = $ind;
my $final_tag = "";
while (@tags)
{
my $t = shift @tags;
my $n = shift @tags;
# print "n is <$n>\n";
my $child;
my $count = 0;
for (@{$rec->{children}})
{
if ($_->{tag} eq $t)
{
$count++;
$child = $_ if !defined $n || $count == $n;
last if $n && $count == $n;
}
}
# print "count is <$count>\n";
# print "child is <$child>\n";
unless ($child)
{
$n = 1 unless defined $n;
$n = $count + 1 unless $n;
# print "n is <$n>\n";
while ($count < $n)
{
$child = Gedcom::Record->new
(
tag => $t,
grammar => $rec->{grammar}->child($t),
);
$count++;
push @{$rec->{children}}, $child;
my $newtag = "${final_tag}_$t$count";
# print "new tag is $newtag\n";
$Top->{_canv}{_ged}{$newtag} = $child;
# print "adding $t $count in ", Dumper $rec;
}
}
$rec = $child;
$final_tag .= "_$t$count";
}
# print "$final_tag from $tag\n";
$final_tag;
push @$cascade,
map {
my $c = $grammar->child($_);
my $t = $_;
# print "child <$t> in <$tag>\n";
(@{$c->{children}} &&
(($tag =~ tr/_//) < 1) &&
($tag !~ /_${t}\d*_/))
? [
Cascade => get_name($t),
-menuitems => add_menu_children($c, $tag)
]
: do {
my $tg = "${tag}_${t}1";
[
Button => get_name($t),
# -state => has_entry($tg) ? "disabled" : "normal",
-command => sub
{
# print "ind is $Rec\n";
my $t = add_record($Rec, $tg);
create_record($Top->{_canv}, $t);
add_show_menu($Rec);
}
]
}
}
sort { get_name($a) cmp get_name($b) }
keys %{$grammar->valid_children};
# print "returning ", Dumper $cascade;
if (@$cascade <= 20)
{
unshift @$cascade, @$menu_items if $menu_items;
return $cascade;
}
my $index = [];
while (@$cascade)
{
my @items = splice(@$cascade, 0, @$cascade > 20 ? 20 : @$cascade);
push @$index,
[
Cascade => "$items[0][1] - $items[-1][1]",
-menuitems => \@items,
];
}
unshift @$index, @$menu_items if $menu_items;
$index;
}
sub add_show_menu($)
{
my ($ind) = @_;
$Top->Busy;
$Top->{_show_menu}->destroy if exists $Top->{_show_menu};
$Top->{_show_menu} = $Top->{_menu_fr}->Menubutton
(
-text => "Show",
-underline => 0,
-menuitems => show_menu_children($ind)
)->pack(-side => "left");
$Top->Unbusy;
}
sub add_add_menu(;$)
{
my ($new) = @_;
# print "adding menu for $Rec->{tag}\n";
$Top->Busy;
if ($new)
{
$Top->{_add_menu}{$Rec->{tag}}->destroy;
delete $Top->{_add_menu}{$Rec->{tag}};
}
unless (exists $Top->{_add_menu}{$Rec->{tag}})
{
# my $fams_id = $Rec->child_value("FAMS");
# my $fams = $fams_id ? $Ged->{xrefs}{$fams_id} : undef;
my $extras =
{
INDI =>
[
[
Button => "Husband",
# -state => $fams && $fams->get_child("_HUSB")
# ? "disabled"
# : "normal",
-command => sub { create_fams("_WIFE", "_HUSB", "_FAMS") }
],
[
Button => "Wife",
# -state => $fams && $fams->get_child("_WIFE")
# ? "disabled"
# : "normal",
-command => sub { create_fams("_HUSB", "_WIFE", "_FAMS") }
],
[
Button => "Child",
-command => sub { create_fams("_HUSB", "_CHIL0", "_FAMC") }
],
],
};
$Top->{_add_menu}{$Rec->{tag}} = $Top->{_menu_fr}->Menubutton
(
-text => "Add",
-underline => 0,
-menuitems => add_menu_children
(
$Ged->{record}{grammar}->child($Rec->{tag}),
undef,
$extras->{$Rec->{tag}} || []
)
)->pack(-side => "left");
}
for (values %{$Top->{_add_menu}})
{
$_->configure(-state => "disabled");
}
$Top->{_add_menu}{$Rec->{tag}}->configure(-state => "normal");
$Top->Unbusy;
}
sub create_fams($$$)
{
my ($me, $child, $fam_type) = @_;
my $fams_id = $Rec->child_value("FAMS");
unless ($fams_id)
{
# TODO - this should be in Gedcom.pm
my $max = 0;
for ($Ged->{record}->get_children("FAM"))
{
if (my ($val) = $_->{xref} =~ /F(\d+)/)
{
$max = $val if $val > $max;
}
}
$max++;
$fams_id = "F$max";
my $fam = Gedcom::Record->new
(
tag => "FAM",
xref => $fams_id,
grammar => $Ged->{record}{grammar}->child("FAM"),
);
# print "new record is ", Dumper $fam;
splice @{$Ged->{record}{children}}, -1, 0, $fam; # before TRLR
$Ged->{xrefs}{$fam->{xref}} = $fam;
my $me_ref = $Rec->{xref}; # TODO should be current value
my $fam_tag = add_record($Rec, "_FAMS");
$Rec->get_child($fam_tag)->{value} = $fams_id;
my $me_tag = add_record($fam, $me);
$fam->get_child($me_tag)->{value} = $me_ref;
}
my $fams = $fams_id ? $Ged->{xrefs}{$fams_id} : undef;
die "No family $fams_id" unless defined $fams;
my $child_tag = add_record($fams, $child);
$fams->get_child($child_tag)->{value} = "";
show_record("", $Rec, "full");
};
sub show_record($$;$$)
{
my ($prefix, $rec, $full, $no_save) = @_;
# print "showing ", Dumper $rec;
save_changes() if $full && !$no_save;
$Rec = $rec unless $prefix;
my $canv = $Top->{_canv};
$Top->Busy;
$canv->{_lines} = 0;
$canv->delete("all");
if ($full)
{
$canv->Walk(sub { shift->destroy });
for my $record (values %{$canv->{_ged}})
{
for (qw( Entry Label Button ))
{
delete $record->{"_$_"};
}
}
delete $canv->{_ged};
}
if (!$rec ||
exists $canv->{_ged}{_XREF1}{xref} &&
$canv->{_ged}{_XREF1}{xref} eq $rec->{xref})
{
$Top->Unbusy;
return;
}
my $key = $prefix . "_XREF1";
$canv->{_ged}{$key} = $rec;
show_children($prefix, $rec, $full);
if ($full)
{
if ($rec->{tag} eq "INDI")
{
my $fams_id = $rec->child_value("FAMS");
my $famc_id = $rec->child_value("FAMC");
my $fams = $fams_id ? $Ged->{xrefs}{$fams_id} : undef;
my $famc = $famc_id ? $Ged->{xrefs}{$famc_id} : undef;
create_person($canv, "Name", "");
create_event ($canv, "Born", "_BIRT1");
create_event ($canv, "Died", "_DEAT1")
if $rec->get_child("DEAT");
# print "displaying rec $rec->{xref} fams ", Dumper $fams;
if ($fams)
{
my $husb = $fams->child_value("HUSB");
create_person($canv, "Husband", "_FAMS1_HUSB1")
if defined $husb && $husb ne $rec->{xref};
my $wife = $fams->child_value("WIFE");
create_person($canv, "Wife", "_FAMS1_WIFE1")
if defined $wife && $wife ne $rec->{xref};
create_event ($canv, "Married", "_FAMS1_MARR1")
if $fams->get_child("MARR");
}
create_person($canv, "Father", "_FAMC1_HUSB1")
if $famc && $famc->get_child("HUSB");
create_person($canv, "Mother", "_FAMC1_WIFE1")
if $famc && $famc->get_child("WIFE");
if ($fams)
{
for (1 .. $fams->child_values("CHIL"))
{
create_person($canv, "Child", "_FAMS1_CHIL$_");
}
}
}
elsif ($rec->{tag} eq "FAM")
{
# print "showing a full family record ", Dumper $rec;
}
# print "setting ", join(", ", sort keys %{$canv->{_ged}}), "\n";
set_entries();
add_add_menu();
add_show_menu($rec);
record_changed();
}
$Top->Unbusy;
}
sub show_children($$$)
{
my ($prefix, $ind, $full) = @_;
my %counts;
for my $child (@{$ind->{children}})
{
my $key = $prefix . "_" . $child->{tag} . ++$counts{$child->{tag}};
# print "key $key for ", Dumper $child;
# print "setting $key to $child->{value}\n" if exists $child->{value};
if (exists $child->{grammar}{value} &&
$child->{grammar}{value} eq '@<XREF:INDI>@')
{
if ($full)
{
show_record($key, $Ged->{xrefs}{$child->{value}});
}
}
elsif (exists $child->{grammar}{value} &&
$child->{grammar}{value} eq '@<XREF:FAM>@')
{
if ($full)
{
show_children($key, $Ged->{xrefs}{$child->{value}}, 1);
}
}
else
{
$Top->{_canv}{_ged}{$key} = $child;
show_children($key, $child) if exists $child->{children};
}
}
}
sub box($@)
{
my ($button, $text, @params) = @_;
my $box = $Top->DialogBox(-default_button => $button,
-buttons => [ $button ],
@params);
my $label = $box->add("Label")->pack(-fill => "both", -expand => 1);
$label->configure(-text => $text);
$box->Show;
}
__END__
=head1 NAME
tkged - an interactive program to manipulate Gedcom genealogy files
Version 1.22 - 15th November 2019
=head1 SYNOPSIS
tkged gedcom_file.ged
=head1 DESCRIPTION
( run in 1.907 second using v1.01-cache-2.11-cpan-39bf76dae61 )