/[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.8 by joko, Wed Feb 19 00:36:59 2003 UTC
# Line 1  Line 1 
1  ## --------------------------------------------------------------------------------  ## ---------------------------------------------------------------------------
2  ##  $Id$  ##  $Id$
3  ## --------------------------------------------------------------------------------  ## ---------------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.8  2003/02/19 00:36:59  joko
6    ##  + bugfix: this {logger} is the instance itself, so has to be fed with ( level => xyz and namespace => xyz )
7    ##  + minor modifications in behaviour
8    ##
9    ##  Revision 1.7  2003/02/18 18:34:35  joko
10    ##  + fix: just logs if possible (sub log_basic)
11    ##
12    ##  Revision 1.6  2003/02/11 11:04:27  joko
13    ##  + metadata (args, caller, etc.) are now stored inside {__bridge}
14    ##
15    ##  Revision 1.5  2003/02/09 16:24:46  joko
16    ##  + pseudo constructor mechanism by calling method 'constructor' on object instantiation
17    ##
18    ##  Revision 1.4  2003/01/22 17:56:49  root
19    ##  + fix: just use the logger if it's available
20    ##
21    ##  Revision 1.3  2003/01/20 16:54:22  joko
22    ##  + sub fromPackage: refactored from libp's 'getNewPerlObjFromPkgName' or s.th.l.th.
23    ##
24  ##  Revision 1.2  2002/12/27 16:05:42  joko  ##  Revision 1.2  2002/12/27 16:05:42  joko
25  ##  + played with Devel::CallerItem and Devel::StackTrace  ##  + played with Devel::CallerItem and Devel::StackTrace
26  ##  ##
27  ##  Revision 1.1  2002/12/13 21:46:29  joko  ##  Revision 1.1  2002/12/13 21:46:29  joko
28  ##  + initial check-in  ##  + initial check-in
29  ##  ##
30  ## --------------------------------------------------------------------------------  ## ---------------------------------------------------------------------------
31    
32    
33  package DesignPattern::Object;  package DesignPattern::Object;
# Line 21  use Data::Dumper; Line 40  use Data::Dumper;
40  #use Devel::CallerItem;  #use Devel::CallerItem;
41  #use Devel::StackTrace;  #use Devel::StackTrace;
42    
43    
44    my $_dp_globals;
45    
46    $_dp_globals = {
47      TRACE => 0,
48    };
49    
50    
51  sub new {  sub new {
52        
53    # the classname in most cases    # the classname in most cases
# Line 29  sub new { Line 56  sub new {
56    # use already blessed reference, if passed in - else use the very classname    # use already blessed reference, if passed in - else use the very classname
57    my $class = ref ($classname) || $classname;    my $class = ref ($classname) || $classname;
58        
59      #$self->log_basic( "$classname->new( ... )" . "\t[via " . __PACKAGE__ . "]" , 'debug');
60      
61    # the base for our object - a plain perl hash, which ....    # the base for our object - a plain perl hash, which ....
62    my $self = {};    my $self = {};
63    # note:    # note:
# Line 42  sub new { Line 71  sub new {
71    # TODO: what about logging in here? inherit from    # TODO: what about logging in here? inherit from
72    # DesignPattern::Object::Logger for this purpose....    # DesignPattern::Object::Logger for this purpose....
73    # ... or would this give us (harmful) circular module dependencies???    # ... or would this give us (harmful) circular module dependencies???
74    #$logger->debug( __PACKAGE__ . "->new( @args )" );      # this is not "common"!    #$self->log_basic( __PACKAGE__ . "->new( @args )", 'debug' );      # this is not "common"!
75    
   # remember the caller  
     $self->{'__caller'} = caller;  
     #print Dumper(caller(2));  
     #exit;  
76            
77    # remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!    # remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!
78    #my $trace = Devel::StackTrace->new();    #my $trace = Devel::StackTrace->new();
# Line 59  sub new { Line 84  sub new {
84    #print Dumper($self);    #print Dumper($self);
85    #exit;    #exit;
86    
87    
88    # argument-handling ...    # argument-handling ...
89    
90      # ... get them ...      # ... get them ...
# Line 74  sub new { Line 100  sub new {
100    # mixin arguments    # mixin arguments
101    $self = { @args };    $self = { @args };
102        
103    # mixin seperate    # scan for arguments prefixed by a double underscore '__'
104    $self->{'__arg'} = $seperate if $seperate;    foreach (keys %$self) {
105        if (/^__(.+?)$/) {
106          $self->{__bridge}->{$1} = $self->{$_};
107          delete $self->{$_};
108        }
109      }
110      
111      # mixin seperate - FIXME: should this not be done after blessing?
112      $self->{__bridge}->{'arg'} = $seperate if $seperate;
113    
114    # ... bless hash into object using classname    # ... bless hash into object using classname
115    bless $self, $class;    bless $self, $class;
116    
117      # remember the caller
118        $self->{__bridge}->{caller_module}  = caller;
119        #print Dumper(caller(2));
120        #exit;
121    
122      $self->{__bridge}->{class_name} = $classname;
123    
124      # patches for backward compatibility
125        $self->{'__arg'} = $self->{__bridge}->{'arg'} if $self->{__bridge}->{'arg'};
126        $self->{'__caller'} = $self->{__bridge}->{caller_module} if $self->{__bridge}->{caller_module};
127        $self->{'__classname'} = $self->{__bridge}->{class_name} if $self->{__bridge}->{class_name};
128    
129    $self->_init() if $self->can('_init');    $self->_init() if $self->can('_init');
130      $self->constructor() if $self->can('constructor');
131    
132      # trace
133        #print Dumper($self);
134        #exit;
135    
136    return $self;    return $self;
137  }    }  
138    
# Line 88  sub _abstract_function { Line 141  sub _abstract_function {
141    my $self_classname = ref $self;    my $self_classname = ref $self;
142    my $function_name = shift;    my $function_name = shift;
143    # was:    # was:
144    # $logger->error( __PACKAGE__ . ": function \"$fName\" is an abstract method, please implement it in \"$class\"");    $self->log_basic( __PACKAGE__ . ": function '$function_name' is an abstract method, please implement it in '$self_classname'.", 'warning');
145    # is:    # is:
146    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'.");
147    #exit;    #exit;
148  }  }
149    
150    sub fromPackage {
151      my $self = shift;
152      #my $self_classname = ref $self;
153      my $pkgname = shift;
154      my @args = @_;
155    #  my $args = shift;
156    
157    #      my $caller = $self->{'__caller'};
158    
159    #print Dumper($args);
160    
161      $self->log_basic( __PACKAGE__ . "->fromPackage( pkgname $pkgname args @args )", 'debug');
162      
163      # perl-load
164        my $evstring = "use $pkgname;";
165        eval($evstring);
166      
167      # report errors
168        if ($@) {
169          # build error-messages
170          my $issuer = __PACKAGE__ . ':' . __LINE__;
171          my $errmsg_native = "Error in eval: " .  $@;
172          #my $classname = $self->{__classname};
173          my $errmsg_critical = '';
174          if ($errmsg_native =~ m/Can't locate (.+?) in \@INC/) {
175            $errmsg_critical = "Could not instantiate object from package '$pkgname' ('$1' not found).";
176          } else {
177            $errmsg_critical = $errmsg_native;
178          }
179          # write error to logging-output (console|file|database)
180          $self->log_basic( $errmsg_native . " (issuer='$issuer', code='$evstring')", 'debug' );
181          $self->log_basic( $errmsg_critical, 'warning' );
182          return;
183        }
184      
185      # object-creation
186        my $object = $pkgname->new(@args);
187    
188      # run boot-methods on object
189        $object->_init() if $object->can('_init');
190        $object->constructor() if $object->can('constructor');
191    
192      return $object;
193    }
194    
195    sub log_basic {
196      my $self = shift;
197      my $message = shift;
198      my $level = shift;
199      
200      #return;
201      $level ||= 'info';
202    
203      if ($_dp_globals->{TRACE} || ($level && $level =~ /warning|error|critical/)) {
204        print $level, ": ", $message, "\n";
205      }
206    
207      # get logger instance
208      if (!$_dp_globals->{logger}) {
209        $_dp_globals->{logger} = eval { Log::Dispatch::Config->instance; };
210      }
211      
212      if ($_dp_globals->{logger}) {
213        $_dp_globals->{logger}->log( level => $level, message => $message);
214      #} else {
215        #print $level, ": ", $message, "\n";
216      }
217      
218    }
219    
220  1;  1;
221    __END__
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.8
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed