/[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.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
25    ##  + 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 13  package DesignPattern::Object; Line 35  package DesignPattern::Object;
35  use strict;  use strict;
36  use warnings;  use warnings;
37    
38    
39    use Data::Dumper;
40    #use Devel::CallerItem;
41    #use Devel::StackTrace;
42    
43    
44    my $_dp_globals;
45    
46    $_dp_globals = {
47      TRACE => 0,
48    };
49    
50    
51    sub new {
52      
53      # the classname in most cases
54      my $classname = shift;
55      
56      # use already blessed reference, if passed in - else use the very classname
57      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 ....
62      my $self = {};
63      # note:
64      # this makes an instance of an arbitrary perl variable,
65      # the most often used for this purpose is - guess it - the hash,
66      # since it resembles object-properties in a convenient way:
67      #   $object->{property} = 'Hello World!';
68      # if you _do_ care about privacy you might take a look
69      # at CPAN's Tie::SecureHash or Class::Contract ...   have fun!
70      
71      # TODO: what about logging in here? inherit from
72      # DesignPattern::Object::Logger for this purpose....
73      # ... or would this give us (harmful) circular module dependencies???
74      #$self->log_basic( __PACKAGE__ . "->new( @args )", 'debug' );      # this is not "common"!
75    
76        
77      # remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!
78      #my $trace = Devel::StackTrace->new();
79      #print Dumper($trace);
80      #print Dumper($trace->frame(1)->args());
81    
82    #print "args: ", $self->{'__caller'}->hasargs(), "\n";
83    
84      #print Dumper($self);
85      #exit;
86    
87    
88      # argument-handling ...
89    
90        # ... get them ...
91        my @args = ();
92        @_ && (@args = @_);
93        
94        # ... check if we can coerce them into an array (this needs an even number of arguments)
95      my $argcount = $#args + 1;
96      my $fract = $argcount / 2;
97      
98      my $seperate = pop @args if $fract != int($fract);
99    
100      # mixin arguments
101      $self = { @args };
102      
103      # scan for arguments prefixed by a double underscore '__'
104      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
115      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');
130      $self->constructor() if $self->can('constructor');
131    
132      # trace
133        #print Dumper($self);
134        #exit;
135    
136      return $self;
137    }  
138    
139  sub _abstract_function {  sub _abstract_function {
140    my $self = shift;    my $self = shift;
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.1  
changed lines
  Added in v.1.8
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed