File Coverage

blib/lib/Ftree/Person.pm
Criterion Covered Total %
statement 18 50 36.0
branch 0 26 0.0
condition 0 33 0.0
subroutine 6 10 60.0
pod 0 4 0.0
total 24 123 19.5


line stmt bran cond sub pod time code
1             #######################################################
2             #
3             # Family Tree generation program, v2.0
4             # Written by Ferenc Bodon and Simon Ward, March 2000 (simonward.com)
5             # Copyright (C) 2000 Ferenc Bodon, Simon K Ward
6             #
7             # This program is free software; you can redistribute it and/or
8             # modify it under the terms of the GNU General Public License
9             # as published by the Free Software Foundation; either version 2
10             # of the License, or (at your option) any later version.
11             #
12             # This program is distributed in the hope that it will be useful,
13             # but WITHOUT ANY WARRANTY; without even the implied warranty of
14             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15             # GNU General Public License for more details.
16             #
17             # For a copy of the GNU General Public License, visit
18             # http://www.gnu.org or write to the Free Software Foundation, Inc.,
19             # 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
20             #
21             #######################################################
22              
23             package Ftree::Person;
24 1     1   6 use strict;
  1         1  
  1         28  
25 1     1   5 use warnings;
  1         2  
  1         32  
26 1     1   4 use version; our $VERSION = qv('2.3.27');
  1         2  
  1         6  
27              
28 1     1   1037 use List::MoreUtils qw(uniq);
  1         12264  
  1         8  
29 1     1   703 use Params::Validate qw(:all);
  1         1  
  1         211  
30              
31 1     1   821 use Class::Std::Storable;
  1         12349  
  1         6  
32             {
33             my %id_of : ATTR(:name<id>);
34             my %name_of : ATTR(:get<name> :set<name>);
35             my %gender_of : ATTR(:get<gender> :set<gender>); #0 for male, 1 for female
36             my %father_of : ATTR(:get<father> :set<father>);
37             my %mother_of : ATTR(:get<mother> :set<mother>);
38             my %children_of : ATTR(:get<children> :set<children>); #ARRAYREF of Person
39             my %email_of : ATTR(:get<email> :set<email>);
40             my %homepage_of : ATTR(:get<homepage> :set<homepage>);
41             my %date_of_birth_of : ATTR(:get<date_of_birth> :set<date_of_birth>);
42             my %date_of_death_of : ATTR(:get<date_of_death> :set<date_of_death>);
43             my %is_living_of : ATTR(:get<is_living> :set<is_living>); #1 for living, 0 for dead
44             my %place_of_birth_of : ATTR(:get<place_of_birth> :set<place_of_birth>);
45             my %place_of_death_of : ATTR(:get<place_of_death> :set<place_of_death>);
46             my %cemetery_of : ATTR(:get<cemetery> :set<cemetery>); # see Cemetery.pm
47             my %schools_of : ATTR(:get<schools> :set<schools>); #ARRAYREF of strings
48             my %jobs_of : ATTR(:get<jobs> :set<jobs>); #ARRAYREF of strings
49             my %work_places_of : ATTR(:get<work_places> :set<work_places>);
50             my %places_of_living_of : ATTR(:get<places_of_living> :set<places_of_living>);
51             my %general_of : ATTR(:get<general> :set<general>);
52             my %default_picture_of : ATTR(:get<default_picture> :set<default_picture>);
53            
54             sub get_spouses {
55 0     0 0   my ($self) = validate_pos(@_, {type => SCALARREF});
56 0 0         return () unless defined $self->get_children();
57            
58 0 0         my ($parent_1, $parent_2) = ($self->get_gender() == 0) ?
59             (\%father_of, \%mother_of) : (\%mother_of, \%father_of);
60            
61 0           my @spouse_set;
62 0           foreach my $child (@{$self->get_children()}) {
  0            
63 0           my $child_ident = ident $child;
64             push @spouse_set, $parent_2->{$child_ident}
65             if($parent_1->{$child_ident} == $self
66 0 0 0       && defined $parent_2->{$child_ident});
67             }
68 0           return uniq @spouse_set;
69             }
70            
71             sub get_peers {
72 0     0 0   my ( $self ) = validate_pos(@_, {type => SCALARREF});
73            
74 0 0 0       if (defined $self->get_mother() && defined $self->get_mother()->get_children()) {
    0 0        
75 0 0 0       return grep { (!defined $_->get_father() && !defined $self->get_father()) ||
76             ($_->get_father() == $self->get_father())}
77 0           @{$self->get_mother()->get_children()};
  0            
78             }
79             elsif (defined $self->get_father() && defined $self->get_father()->get_children()) {
80 0           return grep { !defined $_->get_mother() }
81 0           @{$self->get_father()->get_children()};
  0            
82             }
83             else {
84 0           return ($self);
85             }
86             }
87            
88             sub get_soft_peers {
89 0     0 0   my ( $self, $parent_type ) = validate_pos(@_, {type => SCALARREF},
90             {type => SCALAR});
91            
92 0 0         my ($parent_func, $other_parent_func) = ($parent_type eq 'mother') ?
93             (\&get_mother, \&get_father) : (\&get_father, \&get_mother);
94            
95 0 0         if ( defined $parent_func->($self) ) {
96 0 0 0       return grep {(!defined $other_parent_func->($_) && defined $other_parent_func->($self)) ||
      0        
      0        
      0        
      0        
97             (defined $other_parent_func->($_) && !defined $other_parent_func->($self)) ||
98             (defined $other_parent_func->($_) && defined $other_parent_func->($self) &&
99             $other_parent_func->($_) != $other_parent_func->($self)) }
100 0           @{$parent_func->($self)->get_children()};
  0            
101             }
102             else{
103 0           return ();
104             }
105             }
106            
107             sub brief_info {
108 0     0 0   my ( $self, $textGenerator ) = validate_pos(@_, {type => SCALARREF},
109             {type => HASHREF});
110            
111 0           my $brief_info = "";
112 0 0 0       $brief_info .= $textGenerator->{father} . ': ' . $self->get_father()->get_name()->get_long_name() . ' '
113             if(defined $self->get_father() && defined $self->get_father()->get_name());
114 0 0 0       $brief_info .= $textGenerator->{mother} . ': ' . $self->get_mother()->get_name()->get_long_name() . ' '
115             if(defined $self->get_mother() && defined $self->get_mother()->get_name());
116 0 0         $brief_info .= $textGenerator->{date_of_birth} . ': ' .$self->get_date_of_birth()->format() . ' '
117             if(defined $self->get_date_of_birth());
118 0 0         $brief_info .= $textGenerator->{date_of_death} . ': ' . $self->get_date_of_death()->format() . ' '
119             if(defined $self->get_date_of_death());
120            
121 0           return $brief_info;
122             }
123             }
124              
125             #Static variables for unknown male and female
126             our $unknown_male = Ftree::Person->new( {id => 'unknown_male'} );
127             our $unknown_female = Ftree::Person->new( {id => 'unknown_female'} );
128              
129             $unknown_male->set_gender(0);
130             $unknown_female->set_gender(1);
131              
132             $unknown_male->set_mother($unknown_female);
133             $unknown_male->set_father($unknown_male);
134             $unknown_female->set_mother($unknown_female);
135             $unknown_female->set_father($unknown_male);
136              
137             1;