view release on metacpan or  search on metacpan

tkged  view on Meta::CPAN

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;
}

sub show_menu_children($;$$)
{
  my ($record, $parent, $ind) = @_;
  # TODO - fix this tag
  my $tag = defined $parent ? "${parent}_$record->{tag}1" : "";
  my $canv = $Top->{_canv};
  my $cascade = [];
  push @$cascade,
       [
         Button   => "Self",
         -state   => has_entry($tag) ? "disabled" : "normal",
         -command => sub
                     {
                       create_record($canv, $tag);
                       add_show_menu($ind || $record);
                     }
       ]
    if defined $parent;
  my %c;
  push @$cascade,
       map {
             my $t = $_->{tag} . ++$c{$_->{tag}};
             @{$_->{children}}
               ? [
                   Cascade    => get_name($t),
                   -menuitems => show_menu_children($_, $tag, $ind || $record)
                 ]
               : do {
                      my $tg = "${tag}_$t";
                      [
                        Button   => get_name($t),
                        -state   => has_entry($tg) ? "disabled" : "normal",
                        -command => sub
                                    {
                                      create_record($canv, $tg);
                                      add_show_menu($ind || $record);
                                    }
                      ]
                    }
           }
           sort { get_name($a->{tag}) cmp get_name($b->{tag}) }
                @{$record->{children}};
# print "returning ", Dumper $cascade;
  $cascade;
}

sub add_menu_children($;$$)
{
  my ($grammar, $parent, $menu_items) = @_;
  # print "grammar is $grammar->{tag}\n";
  my $tag = defined $parent ? "${parent}_$grammar->{tag}1" : "";
  my $cascade = [];
  push @$cascade,
       [
         Button   => "Self",
#        -state   => has_entry($tag) ? "disabled" : "normal",
         -command => sub
                     {
                       my $t = add_record($Rec, $tag);
                       create_record($Top->{_canv}, $t);
                       add_show_menu($Rec);
                     }
       ]
    if $parent;
  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") }
        ],