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