r2394 - in packages: . libclass-inner-perl
libclass-inner-perl/branches libclass-inner-perl/branches/upstream
libclass-inner-perl/branches/upstream/current
libclass-inner-perl/branches/upstream/current/t
gregor herrmann
gregoa-guest at costa.debian.org
Fri Mar 17 19:05:34 UTC 2006
Author: gregoa-guest
Date: 2006-03-17 19:05:34 +0000 (Fri, 17 Mar 2006)
New Revision: 2394
Added:
packages/libclass-inner-perl/
packages/libclass-inner-perl/branches/
packages/libclass-inner-perl/branches/upstream/
packages/libclass-inner-perl/branches/upstream/current/
packages/libclass-inner-perl/branches/upstream/current/Changes
packages/libclass-inner-perl/branches/upstream/current/Inner.pm
packages/libclass-inner-perl/branches/upstream/current/MANIFEST
packages/libclass-inner-perl/branches/upstream/current/Makefile.PL
packages/libclass-inner-perl/branches/upstream/current/README
packages/libclass-inner-perl/branches/upstream/current/t/
packages/libclass-inner-perl/branches/upstream/current/t/basic.t
packages/libclass-inner-perl/tags/
Log:
[svn-inject] Installing original source of libclass-inner-perl
Added: packages/libclass-inner-perl/branches/upstream/current/Changes
===================================================================
--- packages/libclass-inner-perl/branches/upstream/current/Changes 2006-03-17 18:58:05 UTC (rev 2393)
+++ packages/libclass-inner-perl/branches/upstream/current/Changes 2006-03-17 19:05:34 UTC (rev 2394)
@@ -0,0 +1,6 @@
+2001-08-12 Piers Cawley <pdcawley at iterative-software.com>
+
+ * Initial release. Everthing working as documented, I think. Now
+ to find out if I'm right, and if what's documented is enough for
+ people
+
Added: packages/libclass-inner-perl/branches/upstream/current/Inner.pm
===================================================================
--- packages/libclass-inner-perl/branches/upstream/current/Inner.pm 2006-03-17 18:58:05 UTC (rev 2393)
+++ packages/libclass-inner-perl/branches/upstream/current/Inner.pm 2006-03-17 19:05:34 UTC (rev 2394)
@@ -0,0 +1,199 @@
+package Class::Inner;
+
+use vars qw/$VERSION/;
+
+$VERSION = 0.1;
+
+
+use strict;
+use Carp;
+
+=head1 NAME
+
+Class::Inner - A perlish implementation of Java like inner classes
+
+=head1 SYNOPSIS
+
+ use Class::Inner;
+
+ my $object = Class::Inner->new(
+ parent => 'ParentClass',
+ methods => { method => sub { ... } }, },
+ constructor => 'new',
+ args => [@constructor_args],
+ );
+
+=head1 DESCRIPTION
+
+Yet another implementation of an anonymous class with per object
+overrideable methods, but with the added attraction of sort of working
+dispatch to the parent class's method.
+
+=head2 METHODS
+
+=over 4
+
+=item B<new HASH>
+
+Takes a hash like argument list with the following keys.
+
+=over 4
+
+=item B<parent>
+
+The name of the parent class. Note that you can only get single
+inheritance with this or B<SUPER> won't work.
+
+=item B<methods>
+
+A hash, keys are method names, values are CODEREFs.
+
+=item B<constructor>
+
+The name of the constructor method. Defaults to 'new'.
+
+=item B<args>
+
+An anonymous array of arguments to pass to the constructor. Defaults
+to an empty list.
+
+=back
+
+Returns an object in an 'anonymous' class which inherits from the
+parent class. This anonymous class has a couple of 'extra' methods:
+
+=over 4
+
+=item B<SUPER>
+
+If you were to pass something like
+
+ $obj = Class::Inner->new(
+ parent => 'Parent',
+ methods => { method => sub { ...; $self->SUPER::method(@_) } },
+ );
+
+then C<$self-C<gt>SUPER::method> almost certainly wouldn't do what you expect,
+so we provide the C<SUPER> method which dispatches to the parent
+implementation of the current method. There seems to be no good way of
+getting the full C<SUPER::> functionality, but I'm working on it.
+
+=item B<DESTROY>
+
+Because B<Class::Inner> works by creating a whole new class name for your
+object, it could potentially leak memory if you create a lot of them. So we
+add a C<DESTROY> method that removes the class from the symbol table once
+it's finished with.
+
+If you need to override a parent's DESTROY method, adding a call to
+C<Class::Inner::clean_symbol_table(ref $self)> to it. Do it at the
+end of the method or your other method calls won't work.
+
+=back
+
+=cut
+
+#'
+
+sub new {
+ my $class = shift;
+ my %args = ref($_[0]) ? %{$_[0]} : @_;
+ my $parent = $args{parent} or
+ croak "Can't work without a parent class\n";
+ my %methods = %{$args{methods}||{}};
+ my $constructor = $args{constructor} || 'new';
+ my @constructor_args = @{$args{args} || []};
+
+ my $anon_class = $class->new_classname;
+
+ no strict 'refs';
+
+ @{"$anon_class\::ISA"} = $parent;
+
+ foreach my $methodname (keys %methods) {
+ *{"$anon_class\::$methodname"} = sub {
+ local $Class::Inner::target_method = $methodname;
+ $methods{$methodname}->(@_);
+ };
+ }
+
+ # Add the SUPER method.
+
+ unless (exists $methods{SUPER}) {
+ *{"$anon_class\::SUPER"} = sub {
+ my $self = shift;
+ my $target_method =
+ join '::', $parent, $Class::Inner::target_method;
+ $self->$target_method(@_);
+ };
+ }
+
+ unless (exists $methods{DESTROY}) {
+ *{"$anon_class\::DESTROY"} = sub {
+ my $self = shift;
+ Class::Inner::clean_symbol_table($anon_class);
+ bless $self, $parent;
+ }
+ }
+ # Instantiate
+ my $obj = $anon_class->new(@constructor_args);
+}
+
+=item B<clean_symbol_table>
+
+The helper subroutine that DESTROY uses to remove the class from the
+symbol table.
+
+=cut
+
+sub clean_symbol_table {
+ my $class = shift;
+ no strict 'refs';
+ foreach my $symbol (keys %{"$class\::"}) {
+ delete ${"$class\::"}{$symbol};
+ }
+ delete $::{"$class\::"};
+}
+
+=item B<new_classname>
+
+Returns a name for the next anonymous class.
+
+=cut
+
+{
+ my $class_counter;
+
+ sub new_classname {
+ my $baseclass = ref($_[0]) || $_[0];
+ return "$baseclass\::__A" . $class_counter++;
+ }
+}
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Copyright (c) 2001 by Piers Cawley E<lt>pdcawley at iterative-software.comE<gt>.
+
+All rights reserved. This program is free software; you can redistribute it
+and/or modify it under the same terms as perl itself.
+
+Thanks to the Iterative Software people: Leon Brocard, Natalie Ford and
+Dave Cross. Also, this module was written initially for use in the
+PerlUnit project, AKA Test::Unit. Kudos to Christian Lemburg and the rest
+of that team.
+
+=head1 SEE ALSO
+
+There are a million and one differen Class constructors available on CPAN,
+none of them does quite what I want, so I wrote this one to add to
+that population where hopefully it will live and thrive.
+
+=head1 BUGS
+
+Bound to be some. Actually the C<SUPER> method is a workaround for what
+I consider to be a bug in perl.
Added: packages/libclass-inner-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libclass-inner-perl/branches/upstream/current/MANIFEST 2006-03-17 18:58:05 UTC (rev 2393)
+++ packages/libclass-inner-perl/branches/upstream/current/MANIFEST 2006-03-17 19:05:34 UTC (rev 2394)
@@ -0,0 +1,6 @@
+Changes
+Inner.pm
+MANIFEST
+README
+Makefile.PL
+t/basic.t
Added: packages/libclass-inner-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libclass-inner-perl/branches/upstream/current/Makefile.PL 2006-03-17 18:58:05 UTC (rev 2393)
+++ packages/libclass-inner-perl/branches/upstream/current/Makefile.PL 2006-03-17 19:05:34 UTC (rev 2394)
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'Class::Inner',
+ 'VERSION_FROM' => 'Inner.pm', # finds $VERSION
+ 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
+);
Added: packages/libclass-inner-perl/branches/upstream/current/README
===================================================================
--- packages/libclass-inner-perl/branches/upstream/current/README 2006-03-17 18:58:05 UTC (rev 2393)
+++ packages/libclass-inner-perl/branches/upstream/current/README 2006-03-17 19:05:34 UTC (rev 2394)
@@ -0,0 +1,17 @@
+INSTALLATION
+ Just perform the usual incantation:
+
+ gunzip Class-Inner-0.1.tar.gz
+ tar -xvf Class-Inner-0.1.tar
+ cd Class-Inner-0.1
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+AUTHOR
+ Copyright (c) 2001 Piers Cawley, <pdcawley at iterative-software.com>.
+
+ All rights reserved. This program is free software; you can
+ redistribute it and/or modify it under the same terms as
+ Perl itself.
Added: packages/libclass-inner-perl/branches/upstream/current/t/basic.t
===================================================================
--- packages/libclass-inner-perl/branches/upstream/current/t/basic.t 2006-03-17 18:58:05 UTC (rev 2393)
+++ packages/libclass-inner-perl/branches/upstream/current/t/basic.t 2006-03-17 19:05:34 UTC (rev 2394)
@@ -0,0 +1,48 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More qw/no_plan/;
+
+BEGIN { use_ok( 'Class::Inner' ); }
+
+package Parent;
+
+sub new { my $class = shift; bless [@_], $class }
+sub a { 'A' };
+sub b { 'B' };
+sub poly { $_[0]->b }
+
+package main;
+
+ok(my $p = Parent->new, "Parent can instantiate");
+ok($p->isa('Parent'), '$p is a Parent');
+is($p->a(), 'A', '$p->a is A');
+is($p->b(), 'B', '$p->b is B');
+is($p->poly(), 'B', '$p->poly is B');
+
+my $ic = Class::Inner->new(
+ parent => 'Parent',
+ methods => { b => sub {
+ my $self = shift;
+ lc($self->SUPER);
+ },
+ c => sub { 'C' } },
+ args => [qw/a b c/]
+ );
+
+ok(ref($ic) && $ic->isa('Parent'),
+ '$ic is a Parent');
+my $ic_class = ref($ic); # Remember this for later...
+ok(eq_array($ic, [qw/a b c/]), 'constructor test');
+
+is($ic->a(), 'A', '$ic->a is A');
+is($ic->b(), 'b', '$ic->b is b');
+is($ic->c(), 'C', '$ic->c is C');
+is($ic->poly(), 'b', '$ic->poly is b');
+
+# Check that destruction works.
+
+$ic = undef;
+
+ok(!$ic_class->isa('Parent'), 'Class dismissed');
Property changes on: packages/libclass-inner-perl/branches/upstream/current/t/basic.t
___________________________________________________________________
Name: svn:executable
+
More information about the Pkg-perl-cvs-commits
mailing list