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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Jan 20 16:54:22 2003 UTC (21 years, 9 months ago) by joko
Branch: MAIN
Changes since 1.2: +68 -10 lines
+ sub fromPackage: refactored from libp's 'getNewPerlObjFromPkgName' or s.th.l.th.

1 joko 1.3 ## ---------------------------------------------------------------------------
2     ## $Id: Object.pm,v 1.2 2002/12/27 16:05:42 joko Exp $
3     ## ---------------------------------------------------------------------------
4 joko 1.2 ## $Log: Object.pm,v $
5 joko 1.3 ## Revision 1.2 2002/12/27 16:05:42 joko
6     ## + played with Devel::CallerItem and Devel::StackTrace
7     ##
8 joko 1.2 ## Revision 1.1 2002/12/13 21:46:29 joko
9     ## + initial check-in
10     ##
11 joko 1.3 ## ---------------------------------------------------------------------------
12 joko 1.1
13    
14     package DesignPattern::Object;
15    
16     use strict;
17     use warnings;
18 joko 1.2
19    
20     use Data::Dumper;
21     #use Devel::CallerItem;
22     #use Devel::StackTrace;
23    
24 joko 1.3
25     # get logger instance
26     my $logger = Log::Dispatch::Config->instance;
27    
28 joko 1.2 sub new {
29    
30     # the classname in most cases
31     my $classname = shift;
32    
33     # use already blessed reference, if passed in - else use the very classname
34     my $class = ref ($classname) || $classname;
35    
36 joko 1.3 $logger->debug( "$classname->new( ... )" . "\t[via " . __PACKAGE__ . "]" );
37    
38 joko 1.2 # the base for our object - a plain perl hash, which ....
39     my $self = {};
40     # note:
41     # this makes an instance of an arbitrary perl variable,
42     # the most often used for this purpose is - guess it - the hash,
43     # since it resembles object-properties in a convenient way:
44     # $object->{property} = 'Hello World!';
45     # if you _do_ care about privacy you might take a look
46     # at CPAN's Tie::SecureHash or Class::Contract ... have fun!
47    
48     # TODO: what about logging in here? inherit from
49     # DesignPattern::Object::Logger for this purpose....
50     # ... or would this give us (harmful) circular module dependencies???
51     #$logger->debug( __PACKAGE__ . "->new( @args )" ); # this is not "common"!
52    
53    
54     # remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!
55     #my $trace = Devel::StackTrace->new();
56     #print Dumper($trace);
57     #print Dumper($trace->frame(1)->args());
58    
59     #print "args: ", $self->{'__caller'}->hasargs(), "\n";
60    
61     #print Dumper($self);
62     #exit;
63    
64 joko 1.3
65 joko 1.2 # argument-handling ...
66    
67     # ... get them ...
68     my @args = ();
69     @_ && (@args = @_);
70    
71     # ... check if we can coerce them into an array (this needs an even number of arguments)
72     my $argcount = $#args + 1;
73     my $fract = $argcount / 2;
74    
75     my $seperate = pop @args if $fract != int($fract);
76    
77     # mixin arguments
78     $self = { @args };
79    
80     # mixin seperate
81     $self->{'__arg'} = $seperate if $seperate;
82    
83     # ... bless hash into object using classname
84     bless $self, $class;
85 joko 1.3
86     # remember the caller
87     $self->{'__caller'} = caller;
88     #print Dumper(caller(2));
89     #exit;
90    
91     $self->{__classname} = $classname;
92    
93 joko 1.2 $self->_init() if $self->can('_init');
94 joko 1.3
95 joko 1.2 return $self;
96     }
97 joko 1.1
98     sub _abstract_function {
99     my $self = shift;
100     my $self_classname = ref $self;
101     my $function_name = shift;
102     # was:
103 joko 1.3 $logger->warning( __PACKAGE__ . ": function '$function_name' is an abstract method, please implement it in '$self_classname'.");
104 joko 1.1 # is:
105 joko 1.3 #die( __PACKAGE__ . ": Function '$function_name' is an abstract method, please implement it in '$self_classname'.");
106 joko 1.1 #exit;
107 joko 1.3 }
108    
109     sub fromPackage {
110     my $self = shift;
111     #my $self_classname = ref $self;
112     my $pkgname = shift;
113     my @args = @_;
114     # my $args = shift;
115    
116     # my $caller = $self->{'__caller'};
117    
118     #print Dumper($args);
119    
120     $logger->debug( __PACKAGE__ . "->fromPackage( pkgname $pkgname args @args )" );
121    
122     # perl-load
123     my $evstring = "use $pkgname;";
124     eval($evstring);
125    
126     # report errors
127     if ($@) {
128     # build error-messages
129     my $errmsg_native = __PACKAGE__ . ':' . __LINE__ . " Error in eval \"$evstring\": " . $@;
130     #my $classname = $self->{__classname};
131     my $errmsg_critical = '';
132     if ($errmsg_native =~ m/Can't locate (.+?) in \@INC/) {
133     $errmsg_critical = "Could not instantiate object from package '$pkgname' - location of '$1' failed.";
134     } else {
135     $errmsg_critical = $errmsg_native;
136     }
137     # write error to logging-output (console|file|database)
138     $logger->debug( $errmsg_native );
139     $logger->critical( $errmsg_critical );
140     return;
141     }
142    
143     # object-creation
144     my $object = $pkgname->new(@args);
145    
146     # run boot-methods on object
147     $object->_init() if $object->can('_init');
148    
149     return $object;
150 joko 1.1 }
151    
152     1;

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