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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by joko, Fri Dec 13 21:46:29 2002 UTC revision 1.6 by joko, Tue Feb 11 11:04:27 2003 UTC
# Line 1  Line 1 
1  ## --------------------------------------------------------------------------------  ## ---------------------------------------------------------------------------
2  ##  $Id$  ##  $Id$
3  ## --------------------------------------------------------------------------------  ## ---------------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.6  2003/02/11 11:04:27  joko
6    ##  + metadata (args, caller, etc.) are now stored inside {__bridge}
7    ##
8    ##  Revision 1.5  2003/02/09 16:24:46  joko
9    ##  + pseudo constructor mechanism by calling method 'constructor' on object instantiation
10    ##
11    ##  Revision 1.4  2003/01/22 17:56:49  root
12    ##  + fix: just use the logger if it's available
13    ##
14    ##  Revision 1.3  2003/01/20 16:54:22  joko
15    ##  + sub fromPackage: refactored from libp's 'getNewPerlObjFromPkgName' or s.th.l.th.
16    ##
17    ##  Revision 1.2  2002/12/27 16:05:42  joko
18    ##  + played with Devel::CallerItem and Devel::StackTrace
19    ##
20  ##  Revision 1.1  2002/12/13 21:46:29  joko  ##  Revision 1.1  2002/12/13 21:46:29  joko
21  ##  + initial check-in  ##  + initial check-in
22  ##  ##
23  ## --------------------------------------------------------------------------------  ## ---------------------------------------------------------------------------
24    
25    
26  package DesignPattern::Object;  package DesignPattern::Object;
# Line 13  package DesignPattern::Object; Line 28  package DesignPattern::Object;
28  use strict;  use strict;
29  use warnings;  use warnings;
30    
31    
32    use Data::Dumper;
33    #use Devel::CallerItem;
34    #use Devel::StackTrace;
35    
36    
37    # get logger instance
38    my $logger = eval { Log::Dispatch::Config->instance; };
39    
40    sub new {
41      
42      # the classname in most cases
43      my $classname = shift;
44      
45      # use already blessed reference, if passed in - else use the very classname
46      my $class = ref ($classname) || $classname;
47      
48      $logger->debug( "$classname->new( ... )" . "\t[via " . __PACKAGE__ . "]" ) if $logger;
49      
50      # the base for our object - a plain perl hash, which ....
51      my $self = {};
52      # note:
53      # this makes an instance of an arbitrary perl variable,
54      # the most often used for this purpose is - guess it - the hash,
55      # since it resembles object-properties in a convenient way:
56      #   $object->{property} = 'Hello World!';
57      # if you _do_ care about privacy you might take a look
58      # at CPAN's Tie::SecureHash or Class::Contract ...   have fun!
59      
60      # TODO: what about logging in here? inherit from
61      # DesignPattern::Object::Logger for this purpose....
62      # ... or would this give us (harmful) circular module dependencies???
63      #$logger->debug( __PACKAGE__ . "->new( @args )" );      # this is not "common"!
64    
65        
66      # remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!
67      #my $trace = Devel::StackTrace->new();
68      #print Dumper($trace);
69      #print Dumper($trace->frame(1)->args());
70    
71    #print "args: ", $self->{'__caller'}->hasargs(), "\n";
72    
73      #print Dumper($self);
74      #exit;
75    
76    
77      # argument-handling ...
78    
79        # ... get them ...
80        my @args = ();
81        @_ && (@args = @_);
82        
83        # ... check if we can coerce them into an array (this needs an even number of arguments)
84      my $argcount = $#args + 1;
85      my $fract = $argcount / 2;
86      
87      my $seperate = pop @args if $fract != int($fract);
88    
89      # mixin arguments
90      $self = { @args };
91      
92      # scan for arguments prefixed by a double underscore '__'
93      foreach (keys %$self) {
94        if (/^__(.+?)$/) {
95          $self->{__bridge}->{$1} = $self->{$_};
96          delete $self->{$_};
97        }
98      }
99      
100      # mixin seperate - FIXME: should this not be done after blessing?
101      $self->{__bridge}->{'arg'} = $seperate if $seperate;
102    
103      # ... bless hash into object using classname
104      bless $self, $class;
105    
106      # remember the caller
107        $self->{__bridge}->{caller_module}  = caller;
108        #print Dumper(caller(2));
109        #exit;
110    
111      $self->{__bridge}->{class_name} = $classname;
112    
113      # patches for backward compatibility
114        $self->{'__arg'} = $self->{__bridge}->{'arg'} if $self->{__bridge}->{'arg'};
115        $self->{'__caller'} = $self->{__bridge}->{caller_module} if $self->{__bridge}->{caller_module};
116        $self->{'__classname'} = $self->{__bridge}->{class_name} if $self->{__bridge}->{class_name};
117    
118      $self->_init() if $self->can('_init');
119      $self->constructor() if $self->can('constructor');
120    
121      # trace
122        #print Dumper($self);
123        #exit;
124    
125      return $self;
126    }  
127    
128  sub _abstract_function {  sub _abstract_function {
129    my $self = shift;    my $self = shift;
130    my $self_classname = ref $self;    my $self_classname = ref $self;
131    my $function_name = shift;    my $function_name = shift;
132    # was:    # was:
133    # $logger->error( __PACKAGE__ . ": function \"$fName\" is an abstract method, please implement it in \"$class\"");    $logger->warning( __PACKAGE__ . ": function '$function_name' is an abstract method, please implement it in '$self_classname'.");
134    # is:    # is:
135    die( __PACKAGE__ . ": Function '$function_name' is an abstract method, please implement it in '$self_classname'.");    #die( __PACKAGE__ . ": Function '$function_name' is an abstract method, please implement it in '$self_classname'.");
136    #exit;    #exit;
137  }  }
138    
139    sub fromPackage {
140      my $self = shift;
141      #my $self_classname = ref $self;
142      my $pkgname = shift;
143      my @args = @_;
144    #  my $args = shift;
145    
146    #      my $caller = $self->{'__caller'};
147    
148    #print Dumper($args);
149    
150      $logger->debug( __PACKAGE__ . "->fromPackage( pkgname $pkgname args @args )" );
151      
152      # perl-load
153        my $evstring = "use $pkgname;";
154        eval($evstring);
155      
156      # report errors
157        if ($@) {
158          # build error-messages
159          my $errmsg_native = __PACKAGE__ . ':' . __LINE__ . " Error in eval \"$evstring\": " .  $@;
160          #my $classname = $self->{__classname};
161          my $errmsg_critical = '';
162          if ($errmsg_native =~ m/Can't locate (.+?) in \@INC/) {
163            $errmsg_critical = "Could not instantiate object from package '$pkgname' - location of '$1' failed.";
164          } else {
165            $errmsg_critical = $errmsg_native;
166          }
167          # write error to logging-output (console|file|database)
168          $logger->debug( $errmsg_native );
169          $logger->critical( $errmsg_critical );
170          return;
171        }
172      
173      # object-creation
174        my $object = $pkgname->new(@args);
175    
176      # run boot-methods on object
177        $object->_init() if $object->can('_init');
178        $object->constructor() if $object->can('constructor');
179    
180      return $object;
181    }
182    
183  1;  1;
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.6
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed