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