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