libs/DesignPattern/Object.pm

## ---------------------------------------------------------------------------
##  $Id: Object.pm,v 1.4 2003/01/22 17:56:49 root Exp $
## ---------------------------------------------------------------------------
##  $Log: Object.pm,v $
##  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;

use strict;
use warnings;


use Data::Dumper;
#use Devel::CallerItem;
#use Devel::StackTrace;


# get logger instance
my $logger = eval { Log::Dispatch::Config->instance; };

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;
  
  $logger->debug( "$classname->new( ... )" . "\t[via " . __PACKAGE__ . "]" ) if $logger;
  
  # 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???
  #$logger->debug( __PACKAGE__ . "->new( @args )" );      # 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 };
  
  # mixin seperate
  $self->{'__arg'} = $seperate if $seperate;

  # ... bless hash into object using classname
  bless $self, $class;

  # remember the caller
    $self->{'__caller'} = caller;
    #print Dumper(caller(2));
    #exit;

  $self->{__classname} = $classname;

  $self->_init() if $self->can('_init');
  $self->constructor() if $self->can('constructor');

  return $self;
}  

sub _abstract_function {
  my $self = shift;
  my $self_classname = ref $self;
  my $function_name = shift;
  # was:
  $logger->warning( __PACKAGE__ . ": function '$function_name' is an abstract method, please implement it in '$self_classname'.");
  # is:
  #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);

  $logger->debug( __PACKAGE__ . "->fromPackage( pkgname $pkgname args @args )" );
  
  # 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' - location of '$1' failed.";
      } else {
        $errmsg_critical = $errmsg_native;
      }
      # write error to logging-output (console|file|database)
      $logger->debug( $errmsg_native );
      $logger->critical( $errmsg_critical );
      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;
}

1;
1	joko	1.3	## ---------------------------------------------------------------------------
2	joko	1.5	## $Id: Object.pm,v 1.4 2003/01/22 17:56:49 root Exp $
3	joko	1.3	## ---------------------------------------------------------------------------
4	joko	1.2	## $Log: Object.pm,v $
5	joko	1.5	## Revision 1.4 2003/01/22 17:56:49 root
6			## + fix: just use the logger if it's available
7			##
8	root	1.4	## Revision 1.3 2003/01/20 16:54:22 joko
9			## + sub fromPackage: refactored from libp's 'getNewPerlObjFromPkgName' or s.th.l.th.
10			##
11	joko	1.3	## Revision 1.2 2002/12/27 16:05:42 joko
12			## + played with Devel::CallerItem and Devel::StackTrace
13			##
14	joko	1.2	## Revision 1.1 2002/12/13 21:46:29 joko
15			## + initial check-in
16			##
17	joko	1.3	## ---------------------------------------------------------------------------
18	joko	1.1
19
20			package DesignPattern::Object;
21
22			use strict;
23			use warnings;
24	joko	1.2
25
26			use Data::Dumper;
27			#use Devel::CallerItem;
28			#use Devel::StackTrace;
29
30	joko	1.3
31			# get logger instance
32	root	1.4	my $logger = eval { Log::Dispatch::Config->instance; };
33	joko	1.3
34	joko	1.2	sub new {
35
36			# the classname in most cases
37			my $classname = shift;
38
39			# use already blessed reference, if passed in - else use the very classname
40			my $class = ref ($classname) \|\| $classname;
41
42	root	1.4	$logger->debug( "$classname->new( ... )" . "\t[via " . __PACKAGE__ . "]" ) if $logger;
43	joko	1.3
44	joko	1.2	# the base for our object - a plain perl hash, which ....
45			my $self = {};
46			# note:
47			# this makes an instance of an arbitrary perl variable,
48			# the most often used for this purpose is - guess it - the hash,
49			# since it resembles object-properties in a convenient way:
50			# $object->{property} = 'Hello World!';
51			# if you _do_ care about privacy you might take a look
52			# at CPAN's Tie::SecureHash or Class::Contract ... have fun!
53
54			# TODO: what about logging in here? inherit from
55			# DesignPattern::Object::Logger for this purpose....
56			# ... or would this give us (harmful) circular module dependencies???
57			#$logger->debug( __PACKAGE__ . "->new( @args )" ); # this is not "common"!
58
59
60			# remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!
61			#my $trace = Devel::StackTrace->new();
62			#print Dumper($trace);
63			#print Dumper($trace->frame(1)->args());
64
65			#print "args: ", $self->{'__caller'}->hasargs(), "\n";
66
67			#print Dumper($self);
68			#exit;
69
70	joko	1.3
71	joko	1.2	# argument-handling ...
72
73			# ... get them ...
74			my @args = ();
75			@_ && (@args = @_);
76
77			# ... check if we can coerce them into an array (this needs an even number of arguments)
78			my $argcount = $#args + 1;
79			my $fract = $argcount / 2;
80
81			my $seperate = pop @args if $fract != int($fract);
82
83			# mixin arguments
84			$self = { @args };
85
86			# mixin seperate
87			$self->{'__arg'} = $seperate if $seperate;
88
89			# ... bless hash into object using classname
90			bless $self, $class;
91	joko	1.3
92			# remember the caller
93			$self->{'__caller'} = caller;
94			#print Dumper(caller(2));
95			#exit;
96
97			$self->{__classname} = $classname;
98
99	joko	1.2	$self->_init() if $self->can('_init');
100	joko	1.5	$self->constructor() if $self->can('constructor');
101	joko	1.3
102	joko	1.2	return $self;
103			}
104	joko	1.1
105			sub _abstract_function {
106			my $self = shift;
107			my $self_classname = ref $self;
108			my $function_name = shift;
109			# was:
110	joko	1.3	$logger->warning( __PACKAGE__ . ": function '$function_name' is an abstract method, please implement it in '$self_classname'.");
111	joko	1.1	# is:
112	joko	1.3	#die( __PACKAGE__ . ": Function '$function_name' is an abstract method, please implement it in '$self_classname'.");
113	joko	1.1	#exit;
114	joko	1.3	}
115
116			sub fromPackage {
117			my $self = shift;
118			#my $self_classname = ref $self;
119			my $pkgname = shift;
120			my @args = @_;
121			# my $args = shift;
122
123			# my $caller = $self->{'__caller'};
124
125			#print Dumper($args);
126
127			$logger->debug( __PACKAGE__ . "->fromPackage( pkgname $pkgname args @args )" );
128
129			# perl-load
130			my $evstring = "use $pkgname;";
131			eval($evstring);
132
133			# report errors
134			if ($@) {
135			# build error-messages
136			my $errmsg_native = __PACKAGE__ . ':' . __LINE__ . " Error in eval \"$evstring\": " . $@;
137			#my $classname = $self->{__classname};
138			my $errmsg_critical = '';
139			if ($errmsg_native =~ m/Can't locate (.+?) in \@INC/) {
140			$errmsg_critical = "Could not instantiate object from package '$pkgname' - location of '$1' failed.";
141			} else {
142			$errmsg_critical = $errmsg_native;
143			}
144			# write error to logging-output (console\|file\|database)
145			$logger->debug( $errmsg_native );
146			$logger->critical( $errmsg_critical );
147			return;
148			}
149
150			# object-creation
151			my $object = $pkgname->new(@args);
152
153			# run boot-methods on object
154			$object->_init() if $object->can('_init');
155	joko	1.5	$object->constructor() if $object->can('constructor');
156	joko	1.3
157			return $object;
158	joko	1.1	}
159
160			1;
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26