/[cvs]/nfo/perl/libs/DesignPattern/Object.pm
ViewVC logotype

Contents of /nfo/perl/libs/DesignPattern/Object.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Tue May 13 08:46:08 2003 UTC (21 years, 5 months ago) by joko
Branch: MAIN
CVS Tags: HEAD
Changes since 1.9: +18 -1 lines
pod and comments

1 ## ---------------------------------------------------------------------------
2 ## $Id: Object.pm,v 1.9 2003/03/27 15:44:32 joko Exp $
3 ## ---------------------------------------------------------------------------
4 ## $Log: Object.pm,v $
5 ## Revision 1.9 2003/03/27 15:44:32 joko
6 ## fixes/enhancements to 'sub log_basic'
7 ##
8 ## Revision 1.8 2003/02/19 00:36:59 joko
9 ## + bugfix: this {logger} is the instance itself, so has to be fed with ( level => xyz and namespace => xyz )
10 ## + minor modifications in behaviour
11 ##
12 ## Revision 1.7 2003/02/18 18:34:35 joko
13 ## + fix: just logs if possible (sub log_basic)
14 ##
15 ## Revision 1.6 2003/02/11 11:04:27 joko
16 ## + metadata (args, caller, etc.) are now stored inside {__bridge}
17 ##
18 ## Revision 1.5 2003/02/09 16:24:46 joko
19 ## + pseudo constructor mechanism by calling method 'constructor' on object instantiation
20 ##
21 ## Revision 1.4 2003/01/22 17:56:49 root
22 ## + fix: just use the logger if it's available
23 ##
24 ## Revision 1.3 2003/01/20 16:54:22 joko
25 ## + sub fromPackage: refactored from libp's 'getNewPerlObjFromPkgName' or s.th.l.th.
26 ##
27 ## Revision 1.2 2002/12/27 16:05:42 joko
28 ## + played with Devel::CallerItem and Devel::StackTrace
29 ##
30 ## Revision 1.1 2002/12/13 21:46:29 joko
31 ## + initial check-in
32 ##
33 ## ---------------------------------------------------------------------------
34
35 =pod
36
37 =head1 NAME
38
39 DesignPattern::Object
40
41
42 =head1 TODO
43
44 o use Class::Loader
45
46
47 =cut
48
49 package DesignPattern::Object;
50
51 use strict;
52 use warnings;
53
54
55 use Data::Dumper;
56 #use Devel::CallerItem;
57 #use Devel::StackTrace;
58
59
60 my $_dp_globals;
61
62 $_dp_globals = {
63 TRACE => 0,
64 };
65
66
67 sub new {
68
69 # the classname in most cases
70 my $classname = shift;
71
72 # use already blessed reference, if passed in - else use the very classname
73 my $class = ref ($classname) || $classname;
74
75 #$self->log_basic( "$classname->new( ... )" . "\t[via " . __PACKAGE__ . "]" , 'debug');
76
77 # the base for our object - a plain perl hash, which ....
78 my $self = {};
79 # note:
80 # this makes an instance of an arbitrary perl variable,
81 # the most often used for this purpose is - guess it - the hash,
82 # since it resembles object-properties in a convenient way:
83 # $object->{property} = 'Hello World!';
84 # if you _do_ care about privacy you might take a look
85 # at CPAN's Tie::SecureHash or Class::Contract ... have fun!
86
87 # TODO: what about logging in here? inherit from
88 # DesignPattern::Object::Logger for this purpose....
89 # ... or would this give us (harmful) circular module dependencies???
90 #$self->log_basic( __PACKAGE__ . "->new( @args )", 'debug' ); # this is not "common"!
91
92
93 # remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!
94 #my $trace = Devel::StackTrace->new();
95 #print Dumper($trace);
96 #print Dumper($trace->frame(1)->args());
97
98 #print "args: ", $self->{'__caller'}->hasargs(), "\n";
99
100 #print Dumper($self);
101 #exit;
102
103
104 # argument-handling ...
105
106 # ... get them ...
107 my @args = ();
108 @_ && (@args = @_);
109
110 # ... check if we can coerce them into an array (this needs an even number of arguments)
111 my $argcount = $#args + 1;
112 my $fract = $argcount / 2;
113
114 my $seperate = pop @args if $fract != int($fract);
115
116 # mixin arguments
117 $self = { @args };
118
119 # scan for arguments prefixed by a double underscore '__'
120 foreach (keys %$self) {
121 if (/^__(.+?)$/) {
122 $self->{__bridge}->{$1} = $self->{$_};
123 delete $self->{$_};
124 }
125 }
126
127 # mixin seperate - FIXME: should this not be done after blessing?
128 $self->{__bridge}->{'arg'} = $seperate if $seperate;
129
130 # ... bless hash into object using classname
131 bless $self, $class;
132
133 # remember the caller
134 $self->{__bridge}->{caller_module} = caller;
135 #print Dumper(caller(2));
136 #exit;
137
138 $self->{__bridge}->{class_name} = $classname;
139
140 # patches for backward compatibility
141 $self->{'__arg'} = $self->{__bridge}->{'arg'} if $self->{__bridge}->{'arg'};
142 $self->{'__caller'} = $self->{__bridge}->{caller_module} if $self->{__bridge}->{caller_module};
143 $self->{'__classname'} = $self->{__bridge}->{class_name} if $self->{__bridge}->{class_name};
144
145 $self->_init() if $self->can('_init');
146 $self->constructor() if $self->can('constructor');
147
148 # trace
149 #print Dumper($self);
150 #exit;
151
152 return $self;
153 }
154
155 sub _abstract_function {
156 my $self = shift;
157 my $self_classname = ref $self;
158 my $function_name = shift;
159 # was:
160 $self->log_basic( __PACKAGE__ . ": function '$function_name' is an abstract method, please implement it in '$self_classname'.", 'warning');
161 # is:
162 #die( __PACKAGE__ . ": Function '$function_name' is an abstract method, please implement it in '$self_classname'.");
163 #exit;
164 }
165
166 sub fromPackage {
167 my $self = shift;
168 #my $self_classname = ref $self;
169 my $pkgname = shift;
170 my @args = @_;
171 # my $args = shift;
172
173 # my $caller = $self->{'__caller'};
174
175 #print Dumper($args);
176
177 $self->log_basic( __PACKAGE__ . "->fromPackage( pkgname $pkgname args @args )", 'debug');
178
179 # perl-load
180 my $evstring = "use $pkgname;";
181 eval($evstring);
182
183 # report errors
184 # Could this be united with DesignPattern::Loader::checkExceptions?
185 if ($@) {
186 # build error-messages
187 my $issuer = __PACKAGE__ . ':' . __LINE__;
188 my $errmsg_native = "Error in eval: " . $@;
189 #my $classname = $self->{__classname};
190 my $errmsg_critical = '';
191 if ($errmsg_native =~ m/Can't locate (.+?) in \@INC/) {
192 $errmsg_critical = "Could not instantiate object from package '$pkgname' ('$1' not found).";
193 } else {
194 $errmsg_critical = $errmsg_native;
195 }
196 # write error to logging-output (console|file|database)
197 $self->log_basic( $errmsg_native . " (issuer='$issuer', code='$evstring')", 'debug' );
198 $self->log_basic( $errmsg_critical, 'warning' );
199 return;
200 }
201
202 # object-creation
203 my $object = $pkgname->new(@args);
204
205 # trace
206 #print Dumper($object);
207
208 # run boot-methods on object
209 $object->_init() if $object->can('_init');
210 $object->constructor() if $object->can('constructor');
211
212 return $object;
213 }
214
215 sub log_basic {
216 my $self = shift;
217 my $message = shift;
218 my $level = shift;
219
220 #return;
221 $level ||= 'info';
222
223 my $notSoGood = ($level =~ /warning|error|critical/);
224
225 # STDERR?
226 if ($level && $notSoGood) {
227 print STDERR $level, ": ", $message, "\n";
228 }
229
230 # STDOUT?
231 if ($_dp_globals->{TRACE} || $notSoGood) {
232 print $level, ": ", $message, "\n";
233 }
234
235 # get logger instance
236 if (!$_dp_globals->{logger}) {
237 $_dp_globals->{logger} = eval { Log::Dispatch::Config->instance; };
238 }
239
240 if ($_dp_globals->{logger}) {
241 $_dp_globals->{logger}->log( level => $level, message => $message);
242 #} else {
243 #print $level, ": ", $message, "\n";
244 }
245
246 }
247
248 1;
249 __END__

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed