view release on metacpan or  search on metacpan

tkged  view on Meta::CPAN

  my $idelete = sub
  {
    if (box("No", "Are you sure you want to delete this record?",
            -title   => "Delete record",
            -buttons => ["Yes", "No"]) eq "Yes")
    {
      my $i = 0;
      for (; $i < @{$Ged->{record}{children}}; $i++)
      {
        last if exists $Ged->{record}{children}[$i]{xref} &&
                $Ged->{record}{children}[$i]{xref} eq $Rec->{xref};
      }
      unless ($i < @{$Ged->{record}{children}})
      {
        box("Whoops",
            "I can't find record $Rec->{xref}",
            -title   => "Unknown record id");
        return;
      }
      delete $Ged->{xrefs}{$Rec->{xref}};
      splice @{$Ged->{record}{children}}, $i, 1;

      for my $fam ($Ged->{record}->get_children("FAM"))
      {
        my $i = 0;
        for (; $i < @{$fam->{children}}; $i++)
        {
          # print "$fam->{tag} $fam->{children}[$i]{tag} ",
          #       "checking $fam->{children}[$i]{value} eq $Rec->{xref}\n";
          last if exists $fam->{children}[$i]{value} &&
                  $fam->{children}[$i]{value} eq $Rec->{xref};
        }
        if ($i < @{$fam->{children}})
        {
          splice @{$fam->{children}}, $i, 1;
        }
      }

      my @individuals = $Ged->{record}->get_children("INDI");
      if (@individuals)
      {
        show_record("", $individuals[0], "full", "no_save");
      }
    }
  };

  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;

tkged  view on Meta::CPAN

                       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") }
        ],
      ],
    };

    $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");
};