libs/DesignPattern/Object.pm

## ---------------------------------------------------------------------------
##  $Id: Object.pm,v 1.9 2003/03/27 15:44:32 joko Exp $
## ---------------------------------------------------------------------------
##  $Log: Object.pm,v $
##  Revision 1.9  2003/03/27 15:44:32  joko
##  fixes/enhancements to 'sub log_basic'
##
##  Revision 1.8  2003/02/19 00:36:59  joko
##  + bugfix: this {logger} is the instance itself, so has to be fed with ( level => xyz and namespace => xyz )
##  + minor modifications in behaviour
##
##  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
##
## ---------------------------------------------------------------------------

=pod

=head1 NAME

  DesignPattern::Object


=head1 TODO

  o use Class::Loader


=cut

package DesignPattern::Object;

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:
  $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'.");
  #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
  # Could this be united with DesignPattern::Loader::checkExceptions?
    if ($@) {
      # build error-messages
      my $issuer = __PACKAGE__ . ':' . __LINE__;
      my $errmsg_native = "Error in eval: " .  $@;
      #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 . " (issuer='$issuer', code='$evstring')", 'debug' );
      $self->log_basic( $errmsg_critical, 'warning' );
      return;
    }
  
  # object-creation
    my $object = $pkgname->new(@args);

  # trace
    #print Dumper($object);

  # 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;
  
  #return;
  $level ||= 'info';

  my $notSoGood = ($level =~ /warning|error|critical/);
  
  # STDERR?
  if ($level && $notSoGood) {
    print STDERR $level, ": ", $message, "\n";
  }

  # STDOUT?
  if ($_dp_globals->{TRACE} || $notSoGood) {
    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 => $level, message => $message);
  #} else {
    #print $level, ": ", $message, "\n";
  }
  
}

1;
__END__
1	joko	1.3	## ---------------------------------------------------------------------------
2	joko	1.10	## $Id: Object.pm,v 1.9 2003/03/27 15:44:32 joko Exp $
3	joko	1.3	## ---------------------------------------------------------------------------
4	joko	1.2	## $Log: Object.pm,v $
5	joko	1.10	## Revision 1.9 2003/03/27 15:44:32 joko
6			## fixes/enhancements to 'sub log_basic'
7			##
8	joko	1.9	## 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	joko	1.8	## Revision 1.7 2003/02/18 18:34:35 joko
13			## + fix: just logs if possible (sub log_basic)
14			##
15	joko	1.7	## Revision 1.6 2003/02/11 11:04:27 joko
16			## + metadata (args, caller, etc.) are now stored inside {__bridge}
17			##
18	joko	1.6	## Revision 1.5 2003/02/09 16:24:46 joko
19			## + pseudo constructor mechanism by calling method 'constructor' on object instantiation
20			##
21	joko	1.5	## Revision 1.4 2003/01/22 17:56:49 root
22			## + fix: just use the logger if it's available
23			##
24	root	1.4	## Revision 1.3 2003/01/20 16:54:22 joko
25			## + sub fromPackage: refactored from libp's 'getNewPerlObjFromPkgName' or s.th.l.th.
26			##
27	joko	1.3	## Revision 1.2 2002/12/27 16:05:42 joko
28			## + played with Devel::CallerItem and Devel::StackTrace
29			##
30	joko	1.2	## Revision 1.1 2002/12/13 21:46:29 joko
31			## + initial check-in
32			##
33	joko	1.3	## ---------------------------------------------------------------------------
34	joko	1.1
35	joko	1.10	=pod
36
37			=head1 NAME
38
39			DesignPattern::Object
40
41
42			=head1 TODO
43
44			o use Class::Loader
45
46
47			=cut
48	joko	1.1
49			package DesignPattern::Object;
50
51			use strict;
52			use warnings;
53	joko	1.2
54
55			use Data::Dumper;
56			#use Devel::CallerItem;
57			#use Devel::StackTrace;
58
59	joko	1.3
60	joko	1.7	my $_dp_globals;
61
62			$_dp_globals = {
63			TRACE => 0,
64			};
65
66	joko	1.3
67	joko	1.2	sub new {
68
69			# the classname in most cases
70			my $classname = shift;
71
72			# use already blessed reference, if passed in - else use the very classname
73			my $class = ref ($classname) \|\| $classname;
74
75	joko	1.7	#$self->log_basic( "$classname->new( ... )" . "\t[via " . __PACKAGE__ . "]" , 'debug');
76	joko	1.3
77	joko	1.2	# the base for our object - a plain perl hash, which ....
78			my $self = {};
79			# note:
80			# this makes an instance of an arbitrary perl variable,
81			# the most often used for this purpose is - guess it - the hash,
82			# since it resembles object-properties in a convenient way:
83			# $object->{property} = 'Hello World!';
84			# if you _do_ care about privacy you might take a look
85			# at CPAN's Tie::SecureHash or Class::Contract ... have fun!
86
87			# TODO: what about logging in here? inherit from
88			# DesignPattern::Object::Logger for this purpose....
89			# ... or would this give us (harmful) circular module dependencies???
90	joko	1.7	#$self->log_basic( __PACKAGE__ . "->new( @args )", 'debug' ); # this is not "common"!
91	joko	1.2
92
93			# remember the stacktrace: abstract this out (DesignPattern::Object::Trace) or parametrize!
94			#my $trace = Devel::StackTrace->new();
95			#print Dumper($trace);
96			#print Dumper($trace->frame(1)->args());
97
98			#print "args: ", $self->{'__caller'}->hasargs(), "\n";
99
100			#print Dumper($self);
101			#exit;
102
103	joko	1.3
104	joko	1.2	# argument-handling ...
105
106			# ... get them ...
107			my @args = ();
108			@_ && (@args = @_);
109
110			# ... check if we can coerce them into an array (this needs an even number of arguments)
111			my $argcount = $#args + 1;
112			my $fract = $argcount / 2;
113
114			my $seperate = pop @args if $fract != int($fract);
115
116			# mixin arguments
117			$self = { @args };
118
119	joko	1.6	# scan for arguments prefixed by a double underscore '__'
120			foreach (keys %$self) {
121			if (/^__(.+?)$/) {
122			$self->{__bridge}->{$1} = $self->{$_};
123			delete $self->{$_};
124			}
125			}
126
127			# mixin seperate - FIXME: should this not be done after blessing?
128			$self->{__bridge}->{'arg'} = $seperate if $seperate;
129	joko	1.2
130			# ... bless hash into object using classname
131			bless $self, $class;
132	joko	1.3
133			# remember the caller
134	joko	1.6	$self->{__bridge}->{caller_module} = caller;
135	joko	1.3	#print Dumper(caller(2));
136			#exit;
137
138	joko	1.6	$self->{__bridge}->{class_name} = $classname;
139
140			# patches for backward compatibility
141			$self->{'__arg'} = $self->{__bridge}->{'arg'} if $self->{__bridge}->{'arg'};
142			$self->{'__caller'} = $self->{__bridge}->{caller_module} if $self->{__bridge}->{caller_module};
143			$self->{'__classname'} = $self->{__bridge}->{class_name} if $self->{__bridge}->{class_name};
144	joko	1.3
145	joko	1.2	$self->_init() if $self->can('_init');
146	joko	1.5	$self->constructor() if $self->can('constructor');
147	joko	1.6
148			# trace
149			#print Dumper($self);
150			#exit;
151	joko	1.3
152	joko	1.2	return $self;
153			}
154	joko	1.1
155			sub _abstract_function {
156			my $self = shift;
157			my $self_classname = ref $self;
158			my $function_name = shift;
159			# was:
160	joko	1.7	$self->log_basic( __PACKAGE__ . ": function '$function_name' is an abstract method, please implement it in '$self_classname'.", 'warning');
161	joko	1.1	# is:
162	joko	1.3	#die( __PACKAGE__ . ": Function '$function_name' is an abstract method, please implement it in '$self_classname'.");
163	joko	1.1	#exit;
164	joko	1.3	}
165
166			sub fromPackage {
167			my $self = shift;
168			#my $self_classname = ref $self;
169			my $pkgname = shift;
170			my @args = @_;
171			# my $args = shift;
172
173			# my $caller = $self->{'__caller'};
174
175			#print Dumper($args);
176
177	joko	1.7	$self->log_basic( __PACKAGE__ . "->fromPackage( pkgname $pkgname args @args )", 'debug');
178	joko	1.3
179			# perl-load
180			my $evstring = "use $pkgname;";
181			eval($evstring);
182
183			# report errors
184	joko	1.10	# Could this be united with DesignPattern::Loader::checkExceptions?
185	joko	1.3	if ($@) {
186			# build error-messages
187	joko	1.8	my $issuer = __PACKAGE__ . ':' . __LINE__;
188			my $errmsg_native = "Error in eval: " . $@;
189	joko	1.3	#my $classname = $self->{__classname};
190			my $errmsg_critical = '';
191			if ($errmsg_native =~ m/Can't locate (.+?) in \@INC/) {
192	joko	1.7	$errmsg_critical = "Could not instantiate object from package '$pkgname' ('$1' not found).";
193	joko	1.3	} else {
194			$errmsg_critical = $errmsg_native;
195			}
196			# write error to logging-output (console\|file\|database)
197	joko	1.8	$self->log_basic( $errmsg_native . " (issuer='$issuer', code='$evstring')", 'debug' );
198	joko	1.7	$self->log_basic( $errmsg_critical, 'warning' );
199	joko	1.3	return;
200			}
201
202			# object-creation
203			my $object = $pkgname->new(@args);
204
205	joko	1.9	# trace
206			#print Dumper($object);
207
208	joko	1.3	# run boot-methods on object
209			$object->_init() if $object->can('_init');
210	joko	1.5	$object->constructor() if $object->can('constructor');
211	joko	1.3
212			return $object;
213	joko	1.1	}
214
215	joko	1.7	sub log_basic {
216			my $self = shift;
217			my $message = shift;
218			my $level = shift;
219	joko	1.8
220			#return;
221			$level \|\|= 'info';
222	joko	1.7
223	joko	1.9	my $notSoGood = ($level =~ /warning\|error\|critical/);
224
225			# STDERR?
226			if ($level && $notSoGood) {
227			print STDERR $level, ": ", $message, "\n";
228			}
229
230			# STDOUT?
231			if ($_dp_globals->{TRACE} \|\| $notSoGood) {
232	joko	1.7	print $level, ": ", $message, "\n";
233			}
234
235			# get logger instance
236			if (!$_dp_globals->{logger}) {
237			$_dp_globals->{logger} = eval { Log::Dispatch::Config->instance; };
238			}
239
240			if ($_dp_globals->{logger}) {
241	joko	1.8	$_dp_globals->{logger}->log( level => $level, message => $message);
242	joko	1.7	#} else {
243			#print $level, ": ", $message, "\n";
244			}
245
246			}
247
248	joko	1.1	1;
249	joko	1.7	__END__
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26