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