Hello community, here is the log from the commit of package perl-Class-Base for openSUSE:Factory checked in at 2012-02-14 19:04:45 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/perl-Class-Base (Old) and /work/SRC/openSUSE:Factory/.perl-Class-Base.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "perl-Class-Base", Maintainer is "" Changes: -------- --- /work/SRC/openSUSE:Factory/perl-Class-Base/perl-Class-Base.changes 2012-01-12 15:26:12.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.perl-Class-Base.new/perl-Class-Base.changes 2012-02-14 19:04:46.000000000 +0100 @@ -1,0 +2,7 @@ +Sat Feb 11 18:52:05 UTC 2012 - [email protected] + +- updated to 0.04 + * Test script is using Test::More instead the home-made ok() and is(). + * Recommend using Badger::Base instead. + +------------------------------------------------------------------- Old: ---- Class-Base-0.03.tar.gz New: ---- Class-Base-0.04.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ perl-Class-Base.spec ++++++ --- /var/tmp/diff_new_pack.1LfZB0/_old 2012-02-14 19:04:47.000000000 +0100 +++ /var/tmp/diff_new_pack.1LfZB0/_new 2012-02-14 19:04:47.000000000 +0100 @@ -15,28 +15,100 @@ # Please submit bugfixes or comments via http://bugs.opensuse.org/ # + Name: perl-Class-Base +Version: 0.04 +Release: 0 %define cpan_name Class-Base -Summary: Useful base class for deriving other modules +Summary: useful base class for deriving other modules License: GPL-1.0+ or Artistic-1.0 Group: Development/Libraries/Perl -Version: 0.03 -Release: 0 Url: http://search.cpan.org/dist/Class-Base/ -Source: http://www.cpan.org/authors/id/A/AB/ABW/Class-Base-%{version}.tar.gz +Source: http://www.cpan.org/authors/id/S/SZ/SZABGAB/%{cpan_name}-%{version}.tar.gz BuildArch: noarch BuildRoot: %{_tmppath}/%{name}-%{version}-build -%{perl_requires} BuildRequires: perl BuildRequires: perl-macros +#BuildRequires: perl(Class::Base) +%{perl_requires} %description +Please consider using the Badger::Base manpage instead which is the +successor of this module. + This module implements a simple base class from which other modules can be -derived, thereby inheriting a number of useful methods such as new(), -init(), params(), clone(), error() and debug(). +derived, thereby inheriting a number of useful methods such as 'new()', +'init()', 'params()', 'clone()', 'error()' and 'debug()'. + +For a number of years, I found myself re-writing this module for +practically every Perl project of any significant size. Or rather, I would +copy the module from the last project and perform a global search and +replace to change the names. Each time it got a little more polished and +eventually, I decided to Do The Right Thing and release it as a module in +it's own right. + +It doesn't pretend to be an all-encompassing solution for every kind of +object creation problem you might encounter. In fact, it only supports +blessed hash references that are created using the popular, but by no means +universal convention of calling 'new()' with a list or reference to a hash +array of named parameters. Constructor failure is indicated by returning +undef and setting the '$ERROR' package variable in the module's class to +contain a relevant message (which you can also fetch by calling 'error()' +as a class method). + +e.g. + + my $object = My::Module->new( + file => 'myfile.html', + msg => 'Hello World' + ) || die $My::Module::ERROR; + +or: + + my $object = My::Module->new({ + file => 'myfile.html', + msg => 'Hello World', + }) || die My::Module->error(); + +The 'new()' method handles the conversion of a list of arguments into a +hash array and calls the 'init()' method to perform any initialisation. In +many cases, it is therefore sufficient to define a module like so: + + package My::Module; + use Class::Base; + use base qw( Class::Base ); + + sub init { + my ($self, $config) = @_; + # copy some config items into $self + $self->params($config, qw( FOO BAR )) || return undef; + return $self; + } + + # ...plus other application-specific methods + + 1; + +Then you can go right ahead and use it like this: + + use My::Module; + + my $object = My::Module->new( FOO => 'the foo value', + BAR => 'the bar value' ) + || die $My::Module::ERROR; + +Despite its limitations, Class::Base can be a surprisingly useful module to +have lying around for those times where you just want to create a regular +object based on a blessed hash reference and don't want to worry too much +about duplicating the same old code to bless a hash, define configuration +values, provide an error reporting mechanism, and so on. Simply derive your +module from 'Class::Base' and leave it to worry about most of the detail. +And don't forget, you can always redefine your own 'new()', 'error()', or +other method, if you don't like the way the Class::Base version works. %prep %setup -q -n %{cpan_name}-%{version} +find . -type f -print0 | xargs -0 chmod 644 %build %{__perl} Makefile.PL INSTALLDIRS=vendor @@ -47,18 +119,11 @@ %install %perl_make_install -# do not perl_process_packlist (noarch) -# remove .packlist file -%{__rm} -rf $RPM_BUILD_ROOT%perl_vendorarch -# remove perllocal.pod file -%{__rm} -rf $RPM_BUILD_ROOT%perl_archlib +%perl_process_packlist %perl_gen_filelist -%clean -%{__rm} -rf $RPM_BUILD_ROOT - %files -f %{name}.files -%defattr(-,root,root,-) +%defattr(-,root,root,755) %doc Changes README TODO %changelog ++++++ Class-Base-0.03.tar.gz -> Class-Base-0.04.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Class-Base-0.03/Changes new/Class-Base-0.04/Changes --- old/Class-Base-0.03/Changes 2002-04-05 11:29:34.000000000 +0200 +++ new/Class-Base-0.04/Changes 2012-02-06 20:19:11.000000000 +0100 @@ -8,12 +8,19 @@ # AUTHOR # Andy Wardley <[email protected]> # -# REVISION -# $Id: Changes,v 1.1.1.1 2002/04/05 09:29:34 abw Exp $ -# #======================================================================== #------------------------------------------------------------------------ +# Version 0.04 2012/02/06 +#------------------------------------------------------------------------ + +* Test script is using Test::More instead the home-made ok() and is(). + +* Recommend using Badger::Base instead. + +* Gabor Szabo co-maintainer. + +#------------------------------------------------------------------------ # Version 0.03 #------------------------------------------------------------------------ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Class-Base-0.03/MANIFEST new/Class-Base-0.04/MANIFEST --- old/Class-Base-0.03/MANIFEST 2002-04-05 11:29:34.000000000 +0200 +++ new/Class-Base-0.04/MANIFEST 2012-02-06 20:19:55.000000000 +0100 @@ -1,7 +1,9 @@ -lib/Class/Base.pm Changes -TODO +lib/Class/Base.pm Makefile.PL -MANIFEST +MANIFEST This list of files README -test.pl +t/test.t +TODO +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Class-Base-0.03/META.json new/Class-Base-0.04/META.json --- old/Class-Base-0.03/META.json 1970-01-01 01:00:00.000000000 +0100 +++ new/Class-Base-0.04/META.json 2012-02-06 20:19:55.000000000 +0100 @@ -0,0 +1,41 @@ +{ + "abstract" : "useful base class for other modules", + "author" : [ + "Andy Wardley <[email protected]>" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112621", + "license" : [ + "unknown" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec";, + "version" : "2" + }, + "name" : "Class-Base", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : 0 + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : 0 + } + }, + "runtime" : { + "requires" : { + "Test::More" : "0.47" + } + } + }, + "release_status" : "stable", + "version" : "0.04" +} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Class-Base-0.03/META.yml new/Class-Base-0.04/META.yml --- old/Class-Base-0.03/META.yml 1970-01-01 01:00:00.000000000 +0100 +++ new/Class-Base-0.04/META.yml 2012-02-06 20:19:55.000000000 +0100 @@ -0,0 +1,22 @@ +--- +abstract: 'useful base class for other modules' +author: + - 'Andy Wardley <[email protected]>' +build_requires: + ExtUtils::MakeMaker: 0 +configure_requires: + ExtUtils::MakeMaker: 0 +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112621' +license: unknown +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: Class-Base +no_index: + directory: + - t + - inc +requires: + Test::More: 0.47 +version: 0.04 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Class-Base-0.03/Makefile.PL new/Class-Base-0.04/Makefile.PL --- old/Class-Base-0.03/Makefile.PL 2002-04-05 11:29:34.000000000 +0200 +++ new/Class-Base-0.04/Makefile.PL 2012-02-06 20:12:07.000000000 +0100 @@ -3,6 +3,9 @@ my %opts = ( 'NAME' => 'Class::Base', 'VERSION_FROM' => 'lib/Class/Base.pm', + 'PREREQ_PM' => { + 'Test::More' => 0.47, + }, ); if ($ExtUtils::MakeMaker::VERSION >= 5.43) { diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Class-Base-0.03/lib/Class/Base.pm new/Class-Base-0.04/lib/Class/Base.pm --- old/Class-Base-0.03/lib/Class/Base.pm 2002-04-05 11:48:51.000000000 +0200 +++ new/Class-Base-0.04/lib/Class/Base.pm 2012-02-06 20:17:46.000000000 +0100 @@ -15,8 +15,6 @@ # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # -# REVISION -# $Id: Base.pm,v 1.2 2002/04/05 09:48:51 abw Exp $ # #======================================================================== @@ -24,8 +22,7 @@ use strict; -our $VERSION = '0.03'; -our $REVISION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/); +our $VERSION = '0.04'; #------------------------------------------------------------------------ @@ -313,6 +310,9 @@ =head1 DESCRIPTION +Please consider using L<Badger::Base> instead which is the successor of +this module. + This module implements a simple base class from which other modules can be derived, thereby inheriting a number of useful methods such as C<new()>, C<init()>, C<params()>, C<clone()>, C<error()> and @@ -772,7 +772,7 @@ =head1 VERSION -This is version 0.03 of Class::Base. +This is version 0.04 of Class::Base. =head1 HISTORY @@ -782,9 +782,11 @@ Thanks to Brian Moseley and Matt Sergeant for suggesting various enhancments, some of which went into version 0.02. +Version 0.04 was uploaded by Gabor Szabo. + =head1 COPYRIGHT -Copyright (C) 1996-2002 Andy Wardley. All Rights Reserved. +Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Class-Base-0.03/t/test.t new/Class-Base-0.04/t/test.t --- old/Class-Base-0.03/t/test.t 1970-01-01 01:00:00.000000000 +0100 +++ new/Class-Base-0.04/t/test.t 2012-02-06 20:01:47.000000000 +0100 @@ -0,0 +1,422 @@ +#!/usr/bin/perl -w # -*- perl -*- +#======================================================================== +# +# test.pl +# +# Test the Class::Base.pm module. +# +# Written by Andy Wardley <[email protected]>, based on the version lifted from +# the Template Toolkit. +# +# This is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. +# +# $Id: test.pl,v 1.1.1.1 2002/04/05 09:29:34 abw Exp $ +# +#======================================================================== + +use strict; +use warnings; +use Class::Base; + + +#------------------------------------------------------------------------ +# mini test harness +#------------------------------------------------------------------------ +use Test::More tests => 93; + +#------------------------------------------------------------------------ +# quick hack to allow STDERR to be tied to a variable. +#------------------------------------------------------------------------ + +package Tie::File2Str; + +sub TIEHANDLE { + my ($class, $textref) = @_; + bless $textref, $class; +} +sub PRINT { + my $self = shift; + $$self .= join('', @_); +} + + +package main; + +# tie STDERR to a variable +my $stderr = ''; +tie(*STDERR, "Tie::File2Str", \$stderr); + + +#------------------------------------------------------------------------ +# Class::Test::Fail always fails, but we check it reports errors OK +#------------------------------------------------------------------------ + +package Class::Test::Fail; +use base qw( Class::Base ); +use vars qw( $ERROR ); + +sub init { + my $self = shift; + return $self->error('expected failure'); +} + + +package main; + +my ($pkg, $mod); + +# instantiate a base class object and test error reporting/returning +$mod = Class::Base->new(); +ok( $mod ); +ok( ! defined $mod->error('barf') ); +ok( $mod->error() eq 'barf' ); + +# Class::Test::Fail should never work, but we check it reports errors OK +$pkg = 'Class::Test::Fail'; +ok( ! $pkg->new() ); +is( $pkg->error, 'expected failure' ); +is( $Class::Test::Fail::ERROR, 'expected failure' ); + + +#------------------------------------------------------------------------ +# Class::Test::Name should only work with a 'name'parameters +#------------------------------------------------------------------------ + +package Class::Test::Name; +use base qw( Class::Base ); +use vars qw( $ERROR ); + +sub init { + my ($self, $params) = @_; + $self->{ NAME } = $params->{ name } + || return $self->error("No name!"); + return $self; +} + +sub name { + $_[0]->{ NAME }; +} + +package main; + +$mod = Class::Test::Name->new(); +ok( ! $mod ); +is( $Class::Test::Name::ERROR, 'No name!' ); +is( Class::Test::Name->error(), 'No name!' ); + +# give it what it wants... +$mod = Class::Test::Name->new({ name => 'foo' }); +ok( $mod ); +ok( ! $mod->error() ); +is( $mod->name(), 'foo' ); + +# ... in 2 different flavours +$mod = Class::Test::Name->new(name => 'foo'); +ok( $mod ); +ok( ! $mod->error() ); +is( $mod->name(), 'foo' ); + +#------------------------------------------------------------------------ +# test clone() method +#------------------------------------------------------------------------ + +my $clone = $mod->clone(); +ok( $mod ); +ok( ! $mod->error() ); +is( $mod->name(), 'foo', 'clone is ok' ); + + +#------------------------------------------------------------------------ +# test id method and constructor parameters +#------------------------------------------------------------------------ + +my $obj = Class::Base->new(); +ok( $obj ); +ok( $obj->id eq 'Class::Base' ); +ok( $obj->id('foo') eq 'foo' ); + +$obj = Class::Base->new( ID => 'foo' ); +ok( $obj ); +ok( $obj->id eq 'foo' ); + +$obj = Class::Base->new( id => 'bar' ); +ok( $obj ); +ok( $obj->id eq 'bar' ); +ok( $obj->id('baz') eq 'baz' ); +ok( $obj->id eq 'baz' ); + +package My::Class::Base; +use base qw( Class::Base ); +our $DEBUG; + +package main; + +$obj = My::Class::Base->new( ); +ok( $obj ); +ok( $obj->id() eq 'My::Class::Base' ); + +$obj = My::Class::Base->new( ID => 'wiz', DEBUG => 1 ); +ok( $obj ); +ok( $obj->id() eq 'wiz' ); +$stderr = ''; +$obj->debug('hello world'); +ok( $stderr eq '[wiz] hello world' ) + or print "stderr is [$stderr] not '[wiz] hello world'\n"; + +#------------------------------------------------------------------------ +# test debugging method and params +#------------------------------------------------------------------------ + +$obj = Class::Base->new( ); +ok( $obj, 'debugging object created' ); +ok( ! $obj->debugging ); +ok( $obj->debugging(1) ); +ok( $obj->debugging ); + +$obj = Class::Base->new( debug => 1 ); +ok( $obj ); +ok( $obj->debugging ); +ok( ! $obj->debugging(0) ); +ok( ! $obj->debugging ); + +$obj = Class::Base->new( DEBUG => 1 ); +ok( $obj ); +ok( $obj->debugging ); +ok( ! $obj->debugging(0) ); +ok( ! $obj->debugging ); + +$obj = My::Class::Base->new( ); +ok( $obj ); +ok( ! $obj->debugging ); +ok( ! $My::Class::Base::DEBUG ); +$stderr = ''; +$obj->debug('hello world'); +ok( ! $stderr ) or print "stderr is [$stderr] not empty'\n"; + + +# no explicit debug flag set in object, so should use package var +$My::Class::Base::DEBUG = 1; +ok( ! $obj->debugging, 'object is not debugging' ); +ok( My::Class::Base->debugging, 'class is debugging' ); +$stderr = ''; +$obj->debug('hello world'); +ok( ! $stderr, 'stderr is empty' ); +My::Class::Base->debug('hello world'); +ok( $stderr eq '[My::Class::Base] hello world' ) + or print "stderr is [$stderr] not '[My::Class::Base] hello world'\n"; + +# now we set an object debug flag which should also change pkg var +$obj->debugging(0); +ok( ! $obj->debugging, 'object debuggin off' ); +ok( $My::Class::Base::DEBUG, 'class debugging on' ); +$stderr = ''; +$obj->debug('hello world'); +ok( ! $stderr ) + or print "stderr is [$stderr] not empty\n"; + +# now that object has debug value defined, it not longer uses pkg var +$My::Class::Base::DEBUG = 1; +ok( ! $obj->debugging ); +$obj->debug('hello world'); +ok( ! $stderr ) + or print "stderr is [$stderr] not empty\n"; + +# test debugging works as class method +My::Class::Base->debugging(0); +ok( ! $My::Class::Base::DEBUG ); + +My::Class::Base->debugging(1); +ok( $My::Class::Base::DEBUG ); + +#------------------------------------------------------------------------ +# test package $DEBUG variable sets default object DEBUG flag +#------------------------------------------------------------------------ + +My::Class::Base->debugging(0); +ok( ! $My::Class::Base::DEBUG, 'class debugging is off' ); + +my $obj1 = My::Class::Base->new( ); +ok( $obj1, 'object 1 created' ); +ok( ! $obj1->debugging, 'object not debugging' ); +$stderr = ''; +$obj1->debug('foo'); +ok( ! $stderr, 'nothing printed' ); + +My::Class::Base->debugging(1); +ok( $My::Class::Base::DEBUG, 'class debugging is now on' ); + +my $obj2 = My::Class::Base->new( ); +ok( $obj2, 'object 2 created' ); +ok( $obj2->debugging, 'object is debugging' ); +$stderr = ''; +$obj2->debug('foo'); +is( $stderr, '[My::Class::Base] foo', 'foo printed' ); + + +#------------------------------------------------------------------------ +# test package var $DEBUG influences debug flag of new objects +#------------------------------------------------------------------------ + +package Some::Class; +use base qw( Class::Base ); + +our $DEBUG = 0 unless defined $DEBUG; +local $" = ', '; + +sub one { + my ($self, @args) = @_; + $self->debug("one(@args)\n"); +} + +sub two { + my ($self, @args) = @_; + $self->debug("two(@args)\n") if $DEBUG; +} + +; + +package main; + +my $a = Some::Class->new(debug => 1); +my $b = Some::Class->new(debug => 1); + +$stderr = ''; +$a->one(2); +$a->two(3); +$b->one(5); +$b->two(7); +is( $stderr, "[Some::Class] one(2)\n[Some::Class] one(5)\n", + 'output 1 matches'); + +$a->debugging(0); +$stderr = ''; +$a->one(11); +$a->two(13); +$b->one(17); +$b->two(19); +is( $stderr, "[Some::Class] one(17)\n", + 'output 2 matches'); + +Some::Class->debugging(1); + +$stderr = ''; +$a->one(23); +$a->two(29); +$b->one(31); +$b->two(37); +is( $stderr, "[Some::Class] one(31)\n[Some::Class] two(37)\n", + 'output 3 matches'); + +#------------------------------------------------------------------------ +# test params() method +#------------------------------------------------------------------------ + +package My::Params::Test; +use base qw( Class::Base ); + +sub init { + my ($self, $config) = @_; + + my ($one, $two, $three) = $self->params($config, qw( ONE TWO THREE )) + || return; + + return $self; +} + +package main; + +$pkg = 'My::Params::Test'; +$obj = $pkg->new(); +ok( $obj, 'got an object' ); +ok( ! exists $obj->{ ONE }, 'ONE does not exist' ); + +$obj = $pkg->new( ONE => 2 ); +ok( $obj, 'got an object' ); +is( $obj->{ ONE }, 2, 'ONE is 2' ); + +$obj = $pkg->new( one => 3, TWO => 4 ); +ok( $obj, 'got an object' ); +is( $obj->{ ONE }, 3, 'ONE is 3' ); +is( $obj->{ TWO }, 4, 'TWO is 4' ); +ok( ! exists $obj->{ THREE }, 'THREE does not exist' ); + + +#------------------------------------------------------------------------ +# same passing list of args +#------------------------------------------------------------------------ + +package My::Other::Params::Test; +use base qw( Class::Base ); + +sub init { + my ($self, $config) = @_; + + my ($one, $two, $three) = $self->params($config, [ qw( ONE TWO THREE ) ]) + || return; + + return $self; +} + +package main; + +$pkg = 'My::Params::Test'; +$obj = $pkg->new(); +ok( $obj, 'got a list ref object' ); +ok( ! exists $obj->{ ONE }, 'ONE does not exist' ); + +$obj = $pkg->new( ONE => 2 ); +is( $obj->{ ONE }, 2, 'ONE is 2' ); + +$obj = $pkg->new( one => 3, TWO => 4 ); +is( $obj->{ ONE }, 3, 'ONE is 3' ); +is( $obj->{ TWO }, 4, 'TWO is 4' ); +ok( ! exists $obj->{ THREE }, 'THREE does not exist' ); + +#------------------------------------------------------------------------ +# same passing hash of defaults +#------------------------------------------------------------------------ + +package My::Hash::Params::Test; +use base qw( Class::Base ); + +sub init { + my ($self, $config) = @_; + + my ($one, $two, $three) = $self->params($config, { + FOO => 'the foo item', + BAR => undef, + BAZ => \&baz, + }) || return; + + return $self; +} + +sub baz { + my ($self, $key, $value) = @_; + $value = '<undef>' unless defined $value; + $self->{ MSG } = "$key set to $value"; + $self->{ BAZ } = $value; +} + +package main; + +$pkg = 'My::Hash::Params::Test'; +$obj = $pkg->new(); +ok( $obj, 'got a hash ref object' ); +is( $obj->{ FOO }, 'the foo item', 'foo default set' ); +ok( ! exists $obj->{ BAR }, 'BAR does not exist' ); +is( $obj->{ BAZ }, '<undef>', 'BAZ is undef' ); +is( $obj->{ MSG }, 'BAZ set to <undef>', 'BAZ is undef' ); + +$obj = $pkg->new( foo => 'hello world', + bar => 99, + baz => 'bazmatic' ); + +is( $obj->{ FOO }, 'hello world', 'foo set' ); +is( $obj->{ BAR }, '99', 'bar set' ); +is( $obj->{ BAZ }, 'bazmatic', 'baz is set' ); +is( $obj->{ MSG }, 'BAZ set to bazmatic', 'MSG is set' ); + + + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Class-Base-0.03/test.pl new/Class-Base-0.04/test.pl --- old/Class-Base-0.03/test.pl 2002-04-05 11:29:34.000000000 +0200 +++ new/Class-Base-0.04/test.pl 1970-01-01 01:00:00.000000000 +0100 @@ -1,438 +0,0 @@ -#!/usr/bin/perl -w # -*- perl -*- -#======================================================================== -# -# test.pl -# -# Test the Class::Base.pm module. -# -# Written by Andy Wardley <[email protected]>, based on the version lifted from -# the Template Toolkit. -# -# This is free software; you can redistribute it and/or modify it -# under the same terms as Perl itself. -# -# $Id: test.pl,v 1.1.1.1 2002/04/05 09:29:34 abw Exp $ -# -#======================================================================== - -use strict; -use warnings; -use lib qw( ./lib ); -use Class::Base; - - -#------------------------------------------------------------------------ -# mini test harness -#------------------------------------------------------------------------ -# use Test::More tests => 93; - -print "1..93\n"; -my $n = 0; - -sub ok { - my ($flag, $msg) = @_; - print(($flag ? 'ok ' : 'not ok '), ++$n, - defined $msg ? " - $msg\n" : "\n"); - return $flag; -} - -sub is { - my ($a, $b, @msg) = @_; - ok( $a eq $b, @msg ); -} - -#------------------------------------------------------------------------ -# quick hack to allow STDERR to be tied to a variable. -#------------------------------------------------------------------------ - -package Tie::File2Str; - -sub TIEHANDLE { - my ($class, $textref) = @_; - bless $textref, $class; -} -sub PRINT { - my $self = shift; - $$self .= join('', @_); -} - - -package main; - -# tie STDERR to a variable -my $stderr = ''; -tie(*STDERR, "Tie::File2Str", \$stderr); - - -#------------------------------------------------------------------------ -# Class::Test::Fail always fails, but we check it reports errors OK -#------------------------------------------------------------------------ - -package Class::Test::Fail; -use base qw( Class::Base ); -use vars qw( $ERROR ); - -sub init { - my $self = shift; - return $self->error('expected failure'); -} - - -package main; - -my ($pkg, $mod); - -# instantiate a base class object and test error reporting/returning -$mod = Class::Base->new(); -ok( $mod ); -ok( ! defined $mod->error('barf') ); -ok( $mod->error() eq 'barf' ); - -# Class::Test::Fail should never work, but we check it reports errors OK -$pkg = 'Class::Test::Fail'; -ok( ! $pkg->new() ); -is( $pkg->error, 'expected failure' ); -is( $Class::Test::Fail::ERROR, 'expected failure' ); - - -#------------------------------------------------------------------------ -# Class::Test::Name should only work with a 'name'parameters -#------------------------------------------------------------------------ - -package Class::Test::Name; -use base qw( Class::Base ); -use vars qw( $ERROR ); - -sub init { - my ($self, $params) = @_; - $self->{ NAME } = $params->{ name } - || return $self->error("No name!"); - return $self; -} - -sub name { - $_[0]->{ NAME }; -} - -package main; - -$mod = Class::Test::Name->new(); -ok( ! $mod ); -is( $Class::Test::Name::ERROR, 'No name!' ); -is( Class::Test::Name->error(), 'No name!' ); - -# give it what it wants... -$mod = Class::Test::Name->new({ name => 'foo' }); -ok( $mod ); -ok( ! $mod->error() ); -is( $mod->name(), 'foo' ); - -# ... in 2 different flavours -$mod = Class::Test::Name->new(name => 'foo'); -ok( $mod ); -ok( ! $mod->error() ); -is( $mod->name(), 'foo' ); - -#------------------------------------------------------------------------ -# test clone() method -#------------------------------------------------------------------------ - -my $clone = $mod->clone(); -ok( $mod ); -ok( ! $mod->error() ); -is( $mod->name(), 'foo', 'clone is ok' ); - - -#------------------------------------------------------------------------ -# test id method and constructor parameters -#------------------------------------------------------------------------ - -my $obj = Class::Base->new(); -ok( $obj ); -ok( $obj->id eq 'Class::Base' ); -ok( $obj->id('foo') eq 'foo' ); - -$obj = Class::Base->new( ID => 'foo' ); -ok( $obj ); -ok( $obj->id eq 'foo' ); - -$obj = Class::Base->new( id => 'bar' ); -ok( $obj ); -ok( $obj->id eq 'bar' ); -ok( $obj->id('baz') eq 'baz' ); -ok( $obj->id eq 'baz' ); - -package My::Class::Base; -use base qw( Class::Base ); -our $DEBUG; - -package main; - -$obj = My::Class::Base->new( ); -ok( $obj ); -ok( $obj->id() eq 'My::Class::Base' ); - -$obj = My::Class::Base->new( ID => 'wiz', DEBUG => 1 ); -ok( $obj ); -ok( $obj->id() eq 'wiz' ); -$stderr = ''; -$obj->debug('hello world'); -ok( $stderr eq '[wiz] hello world' ) - or print "stderr is [$stderr] not '[wiz] hello world'\n"; - -#------------------------------------------------------------------------ -# test debugging method and params -#------------------------------------------------------------------------ - -$obj = Class::Base->new( ); -ok( $obj, 'debugging object created' ); -ok( ! $obj->debugging ); -ok( $obj->debugging(1) ); -ok( $obj->debugging ); - -$obj = Class::Base->new( debug => 1 ); -ok( $obj ); -ok( $obj->debugging ); -ok( ! $obj->debugging(0) ); -ok( ! $obj->debugging ); - -$obj = Class::Base->new( DEBUG => 1 ); -ok( $obj ); -ok( $obj->debugging ); -ok( ! $obj->debugging(0) ); -ok( ! $obj->debugging ); - -$obj = My::Class::Base->new( ); -ok( $obj ); -ok( ! $obj->debugging ); -ok( ! $My::Class::Base::DEBUG ); -$stderr = ''; -$obj->debug('hello world'); -ok( ! $stderr ) or print "stderr is [$stderr] not empty'\n"; - - -# no explicit debug flag set in object, so should use package var -$My::Class::Base::DEBUG = 1; -ok( ! $obj->debugging, 'object is not debugging' ); -ok( My::Class::Base->debugging, 'class is debugging' ); -$stderr = ''; -$obj->debug('hello world'); -ok( ! $stderr, 'stderr is empty' ); -My::Class::Base->debug('hello world'); -ok( $stderr eq '[My::Class::Base] hello world' ) - or print "stderr is [$stderr] not '[My::Class::Base] hello world'\n"; - -# now we set an object debug flag which should also change pkg var -$obj->debugging(0); -ok( ! $obj->debugging, 'object debuggin off' ); -ok( $My::Class::Base::DEBUG, 'class debugging on' ); -$stderr = ''; -$obj->debug('hello world'); -ok( ! $stderr ) - or print "stderr is [$stderr] not empty\n"; - -# now that object has debug value defined, it not longer uses pkg var -$My::Class::Base::DEBUG = 1; -ok( ! $obj->debugging ); -$obj->debug('hello world'); -ok( ! $stderr ) - or print "stderr is [$stderr] not empty\n"; - -# test debugging works as class method -My::Class::Base->debugging(0); -ok( ! $My::Class::Base::DEBUG ); - -My::Class::Base->debugging(1); -ok( $My::Class::Base::DEBUG ); - -#------------------------------------------------------------------------ -# test package $DEBUG variable sets default object DEBUG flag -#------------------------------------------------------------------------ - -My::Class::Base->debugging(0); -ok( ! $My::Class::Base::DEBUG, 'class debugging is off' ); - -my $obj1 = My::Class::Base->new( ); -ok( $obj1, 'object 1 created' ); -ok( ! $obj1->debugging, 'object not debugging' ); -$stderr = ''; -$obj1->debug('foo'); -ok( ! $stderr, 'nothing printed' ); - -My::Class::Base->debugging(1); -ok( $My::Class::Base::DEBUG, 'class debugging is now on' ); - -my $obj2 = My::Class::Base->new( ); -ok( $obj2, 'object 2 created' ); -ok( $obj2->debugging, 'object is debugging' ); -$stderr = ''; -$obj2->debug('foo'); -is( $stderr, '[My::Class::Base] foo', 'foo printed' ); - - -#------------------------------------------------------------------------ -# test package var $DEBUG influences debug flag of new objects -#------------------------------------------------------------------------ - -package Some::Class; -use base qw( Class::Base ); - -our $DEBUG = 0 unless defined $DEBUG; -local $" = ', '; - -sub one { - my ($self, @args) = @_; - $self->debug("one(@args)\n"); -} - -sub two { - my ($self, @args) = @_; - $self->debug("two(@args)\n") if $DEBUG; -} - -; - -package main; - -my $a = Some::Class->new(debug => 1); -my $b = Some::Class->new(debug => 1); - -$stderr = ''; -$a->one(2); -$a->two(3); -$b->one(5); -$b->two(7); -is( $stderr, "[Some::Class] one(2)\n[Some::Class] one(5)\n", - 'output 1 matches'); - -$a->debugging(0); -$stderr = ''; -$a->one(11); -$a->two(13); -$b->one(17); -$b->two(19); -is( $stderr, "[Some::Class] one(17)\n", - 'output 2 matches'); - -Some::Class->debugging(1); - -$stderr = ''; -$a->one(23); -$a->two(29); -$b->one(31); -$b->two(37); -is( $stderr, "[Some::Class] one(31)\n[Some::Class] two(37)\n", - 'output 3 matches'); - -#------------------------------------------------------------------------ -# test params() method -#------------------------------------------------------------------------ - -package My::Params::Test; -use base qw( Class::Base ); - -sub init { - my ($self, $config) = @_; - - my ($one, $two, $three) = $self->params($config, qw( ONE TWO THREE )) - || return; - - return $self; -} - -package main; - -$pkg = 'My::Params::Test'; -$obj = $pkg->new(); -ok( $obj, 'got an object' ); -ok( ! exists $obj->{ ONE }, 'ONE does not exist' ); - -$obj = $pkg->new( ONE => 2 ); -ok( $obj, 'got an object' ); -is( $obj->{ ONE }, 2, 'ONE is 2' ); - -$obj = $pkg->new( one => 3, TWO => 4 ); -ok( $obj, 'got an object' ); -is( $obj->{ ONE }, 3, 'ONE is 3' ); -is( $obj->{ TWO }, 4, 'TWO is 4' ); -ok( ! exists $obj->{ THREE }, 'THREE does not exist' ); - - -#------------------------------------------------------------------------ -# same passing list of args -#------------------------------------------------------------------------ - -package My::Other::Params::Test; -use base qw( Class::Base ); - -sub init { - my ($self, $config) = @_; - - my ($one, $two, $three) = $self->params($config, [ qw( ONE TWO THREE ) ]) - || return; - - return $self; -} - -package main; - -$pkg = 'My::Params::Test'; -$obj = $pkg->new(); -ok( $obj, 'got a list ref object' ); -ok( ! exists $obj->{ ONE }, 'ONE does not exist' ); - -$obj = $pkg->new( ONE => 2 ); -is( $obj->{ ONE }, 2, 'ONE is 2' ); - -$obj = $pkg->new( one => 3, TWO => 4 ); -is( $obj->{ ONE }, 3, 'ONE is 3' ); -is( $obj->{ TWO }, 4, 'TWO is 4' ); -ok( ! exists $obj->{ THREE }, 'THREE does not exist' ); - -#------------------------------------------------------------------------ -# same passing hash of defaults -#------------------------------------------------------------------------ - -package My::Hash::Params::Test; -use base qw( Class::Base ); - -sub init { - my ($self, $config) = @_; - - my ($one, $two, $three) = $self->params($config, { - FOO => 'the foo item', - BAR => undef, - BAZ => \&baz, - }) || return; - - return $self; -} - -sub baz { - my ($self, $key, $value) = @_; - $value = '<undef>' unless defined $value; - $self->{ MSG } = "$key set to $value"; - $self->{ BAZ } = $value; -} - -package main; - -$pkg = 'My::Hash::Params::Test'; -$obj = $pkg->new(); -ok( $obj, 'got a hash ref object' ); -is( $obj->{ FOO }, 'the foo item', 'foo default set' ); -ok( ! exists $obj->{ BAR }, 'BAR does not exist' ); -is( $obj->{ BAZ }, '<undef>', 'BAZ is undef' ); -is( $obj->{ MSG }, 'BAZ set to <undef>', 'BAZ is undef' ); - -$obj = $pkg->new( foo => 'hello world', - bar => 99, - baz => 'bazmatic' ); - -is( $obj->{ FOO }, 'hello world', 'foo set' ); -is( $obj->{ BAR }, '99', 'bar set' ); -is( $obj->{ BAZ }, 'bazmatic', 'baz is set' ); -is( $obj->{ MSG }, 'BAZ set to bazmatic', 'MSG is set' ); - - - -- To unsubscribe, e-mail: [email protected] For additional commands, e-mail: [email protected]
