1package Astro::App::Satpass2::Copier; 2 3use strict; 4use warnings; 5 6use Clone (); 7 8use Astro::App::Satpass2::Utils qw{ @CARP_NOT }; 9use Astro::App::Satpass2::Warner; 10use Scalar::Util 1.26 qw{ blessed }; 11 12our $VERSION = '0.049'; 13 14sub attribute_names { 15 return ( qw{ warner } ); 16} 17 18sub class_name_of_record { 19 my ( $self ) = @_; 20 return ref $self || $self; 21} 22 23sub clone { 24 my ( $self ) = @_; 25 return Clone::clone( $self ); 26} 27 28sub copy { 29 my ( $self, $copy, %skip ) = @_; 30 foreach my $attr ( $self->attribute_names() ) { 31 not exists $skip{$attr} 32 and $copy->can( $attr ) 33 and $copy->$attr( $self->$attr() ); 34 } 35 return $self; 36} 37 38sub create_attribute_methods { 39 my ( $self ) = @_; 40 my $class = ref $self || $self; 41 foreach my $attr ( $self->attribute_names() ) { 42 $class->can( $attr ) and next; 43 my $method = $class . '::' . $attr; 44 no strict qw{ refs }; 45 *$method = sub { 46 my ( $self, @args ) = @_; 47 if ( @args ) { 48 $self->{$attr} = $args[0]; 49 return $self; 50 } else { 51 return $self->{$attr}; 52 } 53 }; 54 } 55 return; 56} 57 58sub init { 59 my ( $self, %arg ) = @_; 60 exists $arg{warner} 61 and $self->warner( delete $arg{warner} ); 62 foreach my $name ( $self->attribute_names() ) { 63 exists $arg{$name} 64 and $self->$name( delete $arg{$name} ); 65 } 66 if ( %arg ) { 67 my @extra = sort keys %arg; 68 $self->wail( 69 join ' ', 'Unknown attribute name(s):', @extra 70 ); 71 } 72 return $self; 73} 74 75sub wail { 76 my ( $self, @args ) = @_; 77 return $self->warner()->wail( @args ); 78} 79 80sub warner { 81 my ( $self, @args ) = @_; 82 if ( @args ) { 83 my $val = shift @args; 84 if ( ! defined $val ) { 85 $val = Astro::App::Satpass2::Warner->new(); 86 } elsif ( ! ref $val && $val->isa( 87 'Astro::App::Satpass2::Warner' ) ) { 88 $val = Astro::App::Satpass2::Warner->new(); 89 } elsif ( ! ( blessed( $val ) && 90 $val->isa('Astro::App::Satpass2::Warner' ) ) ) { 91 $self->wail( 92 'Warner must be undef or an Astro::App::Satpass2::Warner' 93 ); 94 } 95 $self->{warner} = $val; 96 return $self; 97 } else { 98 return $self->{warner} ||= Astro::App::Satpass2::Warner->new(); 99 } 100} 101 102sub weep { 103 my ( $self, @args ) = @_; 104 return $self->warner()->weep( @args ); 105} 106 107sub whinge { 108 my ( $self, @args ) = @_; 109 return $self->warner()->whinge( @args ); 110} 111 1121; 113 114__END__ 115 116=head1 NAME 117 118Astro::App::Satpass2::Copier - Object copying functionality for Astro::App::Satpass2 119 120=head1 SYNOPSIS 121 122 package Astro::App::Satpass2::Foo; 123 124 use strict; 125 use warnings; 126 127 use parent qw{ Astro::App::Satpass2::Copier }; 128 129 sub new { ... } 130 131 sub attribute_names { 132 return ( qw{ bar baz } ); 133 } 134 135 __PACKAGE__->create_attribute_methods(); 136 137 1; 138 139=head1 DETAILS 140 141B<This class is private> to the 142L<Astro::App::Satpass2|Astro::App::Satpass2> package. The author 143reserves the right to modify it in any way or retract it without prior 144notice. 145 146=head1 METHODS 147 148This class supports the following public methods: 149 150=head2 Accessors and Mutators 151 152=head3 warner 153 154 $obj->warner( undef ); 155 my $warner = $obj->warner(); 156 157This method is both accessor and mutator for the C<warner> attribute. 158 159If an argument is passed, it must be either an 160L<Astro::App::Satpass2::Warner|Astro::App::Satpass2::Warner> (either 161class or object), or C<undef> (which causes a new 162L<Astro::App::Satpass2::Warner|Astro::App::Satpass2::Warner> object to 163be created.) 164 165If no argument is passed, it is an accessor, returning the warner 166object. If no such object has been assigned, one will be generated. 167 168=head2 attribute_names 169 170 print join( ', ', $obj->attribute_names() ), "\n"; 171 172This method returns the names of the object's attribute_names. 173 174Subclasses should override this. Immediate subclasses B<should> call 175C<SUPER::attribute_names()>, and indirect subclasses B<must> call 176C<SUPER::attribute_names()>. A subclass' override would look something like 177this: 178 179 sub attribute_names { 180 my ( $self ) = @_; 181 return ( $self->SUPER::attribute_names(), qw{ foo bar baz } ); 182 } 183 184=head2 class_name_of_record 185 186 say 'I am a ', $obj->class_name_of_record(); 187 188This method returns the class name of record of the object. By default 189this is simply the name of the object's class (i.e. C<ref $obj>, but 190subclasses can override this to hide implementation details. 191 192=head2 clone 193 194 my $clone = $obj->clone(); 195 196This method returns a clone of the original object, taken using 197C<Clone::clone()>. 198 199Overrides C<may> call C<SUPER::clone()>. If they do not they bear 200complete responsibility for producing a correct clone of the original 201object. 202 203=head2 copy 204 205 $obj->copy( $copy, %skip ); 206 207This method copies the attribute values of the original object into the 208attribute_names of the copy object. The original object is returned. 209 210The C<%skip> hash is optional. Any attribute that appears in the 211C<%skip> hash is skipped. Note that you can also pass an array here 212provided it has an even number of elements; the even-numbered elements 213(from zero) will be taken as the attribute names. 214 215The copy object need not be the same class as the original, but it must 216support all attributes the original supports. 217 218=head2 create_attribute_methods 219 220 __PACKAGE__->create_attribute_methods(); 221 222This method may be called exactly once by the subclass to create 223accessor/mutator methods. This method assumes that the object is based 224on a hash reference, and stores attribute values in same-named keys in 225the hash. The created methods have the same names as the attributes. 226They are accessors if called without arguments, and mutators returning 227the original object if called with arguments. Methods already in 228existence when this method is called will not be overridden. 229 230=head2 init 231 232 $obj->init( name => value ... ); 233 234This method sets multiple attributes. It dies if any of the names does 235not represent a legal attribute name. It returns the invocant. 236 237=head2 Other Methods 238 239=head3 wail 240 241 $self->wail( 'Something bad happened' ); 242 243This convenience method simply wraps C<< $self->warner()->wail() >>. 244 245=head3 weep 246 247 $self->weep( 'Something really horrible happened' ); 248 249This convenience method simply wraps C<< $self->warner()->weep() >>. 250 251=head3 whinge 252 253 $self->whinge( 'Something annoying happened' ); 254 255This convenience method simply wraps C<< $self->warner()->whinge() >>. 256 257=head1 SUPPORT 258 259Support is by the author. Please file bug reports at 260L<https://rt.cpan.org/Public/Dist/Display.html?Name=Astro-App-Satpass2>, 261L<https://github.com/trwyant/perl-Astro-App-Satpass2/issues>, or in 262electronic mail to the author. 263 264=head1 AUTHOR 265 266Thomas R. Wyant, III F<wyant at cpan dot org> 267 268=head1 COPYRIGHT AND LICENSE 269 270Copyright (C) 2010-2021 by Thomas R. Wyant, III 271 272This program is free software; you can redistribute it and/or modify it 273under the same terms as Perl 5.10.0. For more details, see the full text 274of the licenses in the directory LICENSES. 275 276This program is distributed in the hope that it will be useful, but 277without any warranty; without even the implied warranty of 278merchantability or fitness for a particular purpose. 279 280=cut 281 282# ex: set textwidth=72 : 283