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