--- nfo/perl/libs/DesignPattern/Object.pm	2002/12/13 21:46:29	1.1
+++ nfo/perl/libs/DesignPattern/Object.pm	2003/02/18 18:34:35	1.7
@@ -1,11 +1,29 @@
-## --------------------------------------------------------------------------------
-##  $Id: Object.pm,v 1.1 2002/12/13 21:46:29 joko Exp $
-## --------------------------------------------------------------------------------
+## ---------------------------------------------------------------------------
+##  $Id: Object.pm,v 1.7 2003/02/18 18:34:35 joko Exp $
+## ---------------------------------------------------------------------------
 ##  $Log: Object.pm,v $
+##  Revision 1.7  2003/02/18 18:34:35  joko
+##  + fix: just logs if possible (sub log_basic)
+##
+##  Revision 1.6  2003/02/11 11:04:27  joko
+##  + metadata (args, caller, etc.) are now stored inside {__bridge}
+##
+##  Revision 1.5  2003/02/09 16:24:46  joko
+##  + pseudo constructor mechanism by calling method 'constructor' on object instantiation
+##
+##  Revision 1.4  2003/01/22 17:56:49  root
+##  + fix: just use the logger if it's available
+##
+##  Revision 1.3  2003/01/20 16:54:22  joko
+##  + sub fromPackage: refactored from libp's 'getNewPerlObjFromPkgName' or s.th.l.th.
+##
+##  Revision 1.2  2002/12/27 16:05:42  joko
+##  + played with Devel::CallerItem and Devel::StackTrace
+##
 ##  Revision 1.1  2002/12/13 21:46:29  joko
 ##  + initial check-in
 ##
-## --------------------------------------------------------------------------------
+## ---------------------------------------------------------------------------
 
 
 package DesignPattern::Object;
@@ -13,15 +31,183 @@
 use strict;
 use warnings;
 
+
+use Data::Dumper;
+#use Devel::CallerItem;
+#use Devel::StackTrace;
+
+
+my $_dp_globals;
+
+$_dp_globals = {
+  TRACE => 0,
+};
+
+
+sub new {
+  
+  # the classname in most cases
+  my $classname = shift;
+  
+  # use already blessed reference, if passed in - else use the very classname
+  my $class = ref ($classname) || $classname;
+  
+  #$self->log_basic( "$classname->new( ... )" . "\t[via " . __PACKAGE__ . "]" , 'debug');
+  
+  # the base for our object - a plain perl hash, which ....
+  my $self = {};
+  # note:
+  # this makes an instance of an arbitrary perl variable,
+  # the most often used for this purpose is - guess it - the hash, 
+  # since it resembles object-properties in a convenient way:
+  #   $object->{property} = 'Hello World!';
+  # if you _do_ care about privacy you might take a look 
+  # at CPAN's Tie::SecureHash or Class::Contract ...   have fun!
+  
+  # TODO: what about logging in here? inherit from 
+  # DesignPattern::Object::Logger for this purpose....
+  # ... or would this give us (harmful) circular module dependencies???
+  #$self->log_basic( __PACKAGE__ . "->new( @args )", 'debug' );      # this is not "common"!
+
+    
+  # remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!
+  #my $trace = Devel::StackTrace->new();
+  #print Dumper($trace);
+  #print Dumper($trace->frame(1)->args());
+
+#print "args: ", $self->{'__caller'}->hasargs(), "\n";
+
+  #print Dumper($self);
+  #exit;
+
+
+  # argument-handling ...
+
+    # ... get them ...
+    my @args = ();
+    @_ && (@args = @_);
+    
+    # ... check if we can coerce them into an array (this needs an even number of arguments)
+  my $argcount = $#args + 1;
+  my $fract = $argcount / 2;
+  
+  my $seperate = pop @args if $fract != int($fract);
+
+  # mixin arguments
+  $self = { @args };
+  
+  # scan for arguments prefixed by a double underscore '__'
+  foreach (keys %$self) {
+    if (/^__(.+?)$/) {
+      $self->{__bridge}->{$1} = $self->{$_};
+      delete $self->{$_};
+    }
+  }
+  
+  # mixin seperate - FIXME: should this not be done after blessing?
+  $self->{__bridge}->{'arg'} = $seperate if $seperate;
+
+  # ... bless hash into object using classname
+  bless $self, $class;
+
+  # remember the caller
+    $self->{__bridge}->{caller_module}  = caller;
+    #print Dumper(caller(2));
+    #exit;
+
+  $self->{__bridge}->{class_name} = $classname;
+
+  # patches for backward compatibility
+    $self->{'__arg'} = $self->{__bridge}->{'arg'} if $self->{__bridge}->{'arg'};
+    $self->{'__caller'} = $self->{__bridge}->{caller_module} if $self->{__bridge}->{caller_module};
+    $self->{'__classname'} = $self->{__bridge}->{class_name} if $self->{__bridge}->{class_name};
+
+  $self->_init() if $self->can('_init');
+  $self->constructor() if $self->can('constructor');
+
+  # trace
+    #print Dumper($self);
+    #exit;
+
+  return $self;
+}  
+
 sub _abstract_function {
   my $self = shift;
   my $self_classname = ref $self;
   my $function_name = shift;
   # was:
-  # $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');
   # is:
-  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'.");
   #exit;
 }
 
+sub fromPackage {
+  my $self = shift;
+  #my $self_classname = ref $self;
+  my $pkgname = shift;
+  my @args = @_;
+#  my $args = shift;
+
+#      my $caller = $self->{'__caller'};
+
+#print Dumper($args);
+
+  $self->log_basic( __PACKAGE__ . "->fromPackage( pkgname $pkgname args @args )", 'debug');
+  
+  # perl-load
+    my $evstring = "use $pkgname;";
+    eval($evstring);
+  
+  # report errors
+    if ($@) {
+      # build error-messages
+      my $errmsg_native = __PACKAGE__ . ':' . __LINE__ . " Error in eval \"$evstring\": " .  $@;
+      #my $classname = $self->{__classname};
+      my $errmsg_critical = '';
+      if ($errmsg_native =~ m/Can't locate (.+?) in \@INC/) {
+        $errmsg_critical = "Could not instantiate object from package '$pkgname' ('$1' not found).";
+      } else {
+        $errmsg_critical = $errmsg_native;
+      }
+      # write error to logging-output (console|file|database)
+      $self->log_basic( $errmsg_native, 'debug' );
+      $self->log_basic( $errmsg_critical, 'warning' );
+      return;
+    }
+  
+  # object-creation
+    my $object = $pkgname->new(@args);
+
+  # run boot-methods on object
+    $object->_init() if $object->can('_init');
+    $object->constructor() if $object->can('constructor');
+
+  return $object;
+}
+
+sub log_basic {
+  my $self = shift;
+  my $message = shift;
+  my $level = shift;
+
+  if ($_dp_globals->{TRACE} || ($level && $level =~ /warning|error|critical/)) {
+    print $level, ": ", $message, "\n";
+  }
+
+  # get logger instance
+  if (!$_dp_globals->{logger}) {
+    $_dp_globals->{logger} = eval { Log::Dispatch::Config->instance; };
+  }
+  
+  if ($_dp_globals->{logger}) {
+    $_dp_globals->{logger}->log($level, $message);
+  #} else {
+    #print $level, ": ", $message, "\n";
+  }
+  
+}
+
 1;
+__END__