/[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.2 by joko, Fri Dec 27 16:05:42 2002 UTC revision 1.5 by joko, Sun Feb 9 16:24:46 2003 UTC
# Line 1  Line 1 
1  ## --------------------------------------------------------------------------------  ## ---------------------------------------------------------------------------
2  ##  $Id$  ##  $Id$
3  ## --------------------------------------------------------------------------------  ## ---------------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.5  2003/02/09 16:24:46  joko
6    ##  + pseudo constructor mechanism by calling method 'constructor' on object instantiation
7    ##
8    ##  Revision 1.4  2003/01/22 17:56:49  root
9    ##  + fix: just use the logger if it's available
10    ##
11    ##  Revision 1.3  2003/01/20 16:54:22  joko
12    ##  + sub fromPackage: refactored from libp's 'getNewPerlObjFromPkgName' or s.th.l.th.
13    ##
14  ##  Revision 1.2  2002/12/27 16:05:42  joko  ##  Revision 1.2  2002/12/27 16:05:42  joko
15  ##  + played with Devel::CallerItem and Devel::StackTrace  ##  + played with Devel::CallerItem and Devel::StackTrace
16  ##  ##
17  ##  Revision 1.1  2002/12/13 21:46:29  joko  ##  Revision 1.1  2002/12/13 21:46:29  joko
18  ##  + initial check-in  ##  + initial check-in
19  ##  ##
20  ## --------------------------------------------------------------------------------  ## ---------------------------------------------------------------------------
21    
22    
23  package DesignPattern::Object;  package DesignPattern::Object;
# Line 21  use Data::Dumper; Line 30  use Data::Dumper;
30  #use Devel::CallerItem;  #use Devel::CallerItem;
31  #use Devel::StackTrace;  #use Devel::StackTrace;
32    
33    
34    # get logger instance
35    my $logger = eval { Log::Dispatch::Config->instance; };
36    
37  sub new {  sub new {
38        
39    # the classname in most cases    # the classname in most cases
# Line 29  sub new { Line 42  sub new {
42    # use already blessed reference, if passed in - else use the very classname    # use already blessed reference, if passed in - else use the very classname
43    my $class = ref ($classname) || $classname;    my $class = ref ($classname) || $classname;
44        
45      $logger->debug( "$classname->new( ... )" . "\t[via " . __PACKAGE__ . "]" ) if $logger;
46      
47    # the base for our object - a plain perl hash, which ....    # the base for our object - a plain perl hash, which ....
48    my $self = {};    my $self = {};
49    # note:    # note:
# Line 44  sub new { Line 59  sub new {
59    # ... or would this give us (harmful) circular module dependencies???    # ... or would this give us (harmful) circular module dependencies???
60    #$logger->debug( __PACKAGE__ . "->new( @args )" );      # this is not "common"!    #$logger->debug( __PACKAGE__ . "->new( @args )" );      # this is not "common"!
61    
   # remember the caller  
     $self->{'__caller'} = caller;  
     #print Dumper(caller(2));  
     #exit;  
62            
63    # remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!    # remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!
64    #my $trace = Devel::StackTrace->new();    #my $trace = Devel::StackTrace->new();
# Line 59  sub new { Line 70  sub new {
70    #print Dumper($self);    #print Dumper($self);
71    #exit;    #exit;
72    
73    
74    # argument-handling ...    # argument-handling ...
75    
76      # ... get them ...      # ... get them ...
# Line 79  sub new { Line 91  sub new {
91    
92    # ... bless hash into object using classname    # ... bless hash into object using classname
93    bless $self, $class;    bless $self, $class;
94    
95      # remember the caller
96        $self->{'__caller'} = caller;
97        #print Dumper(caller(2));
98        #exit;
99    
100      $self->{__classname} = $classname;
101    
102    $self->_init() if $self->can('_init');    $self->_init() if $self->can('_init');
103      $self->constructor() if $self->can('constructor');
104    
105    return $self;    return $self;
106  }    }  
107    
# Line 88  sub _abstract_function { Line 110  sub _abstract_function {
110    my $self_classname = ref $self;    my $self_classname = ref $self;
111    my $function_name = shift;    my $function_name = shift;
112    # was:    # was:
113    # $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'.");
114    # is:    # is:
115    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'.");
116    #exit;    #exit;
117  }  }
118    
119    sub fromPackage {
120      my $self = shift;
121      #my $self_classname = ref $self;
122      my $pkgname = shift;
123      my @args = @_;
124    #  my $args = shift;
125    
126    #      my $caller = $self->{'__caller'};
127    
128    #print Dumper($args);
129    
130      $logger->debug( __PACKAGE__ . "->fromPackage( pkgname $pkgname args @args )" );
131      
132      # perl-load
133        my $evstring = "use $pkgname;";
134        eval($evstring);
135      
136      # report errors
137        if ($@) {
138          # build error-messages
139          my $errmsg_native = __PACKAGE__ . ':' . __LINE__ . " Error in eval \"$evstring\": " .  $@;
140          #my $classname = $self->{__classname};
141          my $errmsg_critical = '';
142          if ($errmsg_native =~ m/Can't locate (.+?) in \@INC/) {
143            $errmsg_critical = "Could not instantiate object from package '$pkgname' - location of '$1' failed.";
144          } else {
145            $errmsg_critical = $errmsg_native;
146          }
147          # write error to logging-output (console|file|database)
148          $logger->debug( $errmsg_native );
149          $logger->critical( $errmsg_critical );
150          return;
151        }
152      
153      # object-creation
154        my $object = $pkgname->new(@args);
155    
156      # run boot-methods on object
157        $object->_init() if $object->can('_init');
158        $object->constructor() if $object->can('constructor');
159    
160      return $object;
161    }
162    
163  1;  1;
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.5
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed