package Object::Info;
require Exporter;
require UNIVERSAL;

@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(is_object superclasses is_kind_of );

$VERSION = 1.1; sub Version {$VERSION}

# THESE ARE FUNCTIONS, NOT METHODS

sub superclasses {@{$_[0]->class().'::ISA'}}
sub is_object {
    my($thing) = @_;
    eval {$thing->is_instance()};
    !$@; 
}

sub subs_in_class {
    my($class) = @_;
    exists($main::{$class . '::'}) || return undef;
    my($p,$q,@meths);
    while ( ($p,$q) = each %{$class . '::'}) {
	defined(&$q) && push(@meths,$p);
    }
    @meths;
}

sub traverse_full_hierarchy {
    my($class,$test) = @_;
    $test ||= sub {};
    my $hierarchy = [$class,[superclasses($class),'UNIVERSAL']];
    _hierarchy($hierarchy,0,$test);
    $hierarchy;
}

sub _hierarchy {
    my($c_s_pair,$depth,$test) = @_;

    my $class = $c_s_pair->[0];
    &$test($class,$depth);
    my $supers = $c_s_pair->[1];
    my $i;

    if ($#{$supers} != -1) {
	for ($i = 0; $i <= $#{$supers}; $i++) {
	    $supers->[$i] = [$supers->[$i],[superclasses($supers->[$i])] ];
	    _hierarchy($supers->[$i],$depth+1,$test);
	}
    }
}


sub uniquely_traverse_hierarchy {
    my($obj,$test) = @_;

    # Takes an object from which to start the hierarchy traversal,
    # and a test method to call on each class. The test method is passed
    # the current class as an argument, and the traversal terminates
    # as soon as the test method returns TRUE. Classes are checked only
    # once, even if they are in the hierarchy multiple times (and their
    # hierarchies are traversed only once) for efficiency.

    my(@classes,%seen,$cls,$superclass);
    $cls = $obj->class();
    @classes = ($cls);
    $seen{$cls} = 1;
    while ($cls = shift(@classes)) {
        foreach $superclass ( @{ $cls . '::ISA' } ) {
            $seen{$superclass} ? next : $seen{$superclass}++;
	    &$test($superclass) && return 1;
            push(@classes,$superclass);
        }
    }
    &$test('UNIVERSAL');
}

sub responds_to {
    my($obj,$method_name) = @_;
    $obj = $obj->class();
    defined(  &{   ${$obj . '::'}{$method_name}   }   ) && return 1;
    uniquely_traverse_hierarchy($obj,sub {defined( &{ ${$_[0] . '::'}{$method_name} } )});
}

sub is_kind_of {
    my($obj,$ancestor) = @_;
    $obj = $obj->class();
    $ancestor = $ancestor->class();
    $obj eq $ancestor && return 1;
    uniquely_traverse_hierarchy($obj,sub {$ancestor eq $_[0]});
}

sub subclass_responsibility {
    my($callpack,$f,$l,$meth) = caller(1);
    $meth =~ s/^(.*):://;
    my $callpack  = $1;
    die 'Error: the method "',$meth,'" was called in class "',$callpack,
	'" by an object of class "',(ref($obj) ? ref($obj) : $obj),
	'" but should have been re-implemented in a subclass.',"\n";
}

sub should_not_implement {
    my($callpack,$f,$l,$meth) = caller(1);
    $meth =~ s/^.*:://;
    my($callpack) = caller(0);
    die 'Error: the method "',$meth,'" was called in class "',$callpack,
	'" by an object of class "',(ref($obj) ? ref($obj) : $obj),
	'" but this method has been specifically disallowed.',"\n";
}

1;
__END__

=head1 NAME

Object::Info - behaviour for objects

=head1 SYNOPSIS

Usage:

    use Object::Info qw(is_object superclasses is_kind_of ...);
    
    $bool = is_object($some_scalar);
    @immediate_superclasses = superclasses($obj);
    $bool = is_kind_of($obj,$some_class);
    
    sub meth {subclass_responsibility()}
    sub meth {should_not_implement()}


=head1 DESCRIPTION

Provides functions for getting information about objects.

=over 4

=item is_object(THING)

This function can be used to test whether any particular scalar
is an object. An object is anything that can invoke a method, i.e.
blessed scalars and package names. It returns true if THING
is an object, false otherwise.

Note that ublessed scalars like [] are NOT objects. If you wanted
to test for either case, you could use something like:

    ref($some_scalar) || is_object($some_scalar);

=item superclasses(OBJECT)

This function returns the @ISA array for the OBJECT's package;

=item is_kind_of(OBJECT1,OBJECT2)

This function returns true if the class of OBJECT1 is the same as
the class of the OBJECT2 or one its superclasses, false otherwise.
So if 'A' is a subclass of 'B', and 'B' is a subclass of 'C',
then

  A->is_kind_of(A);
  A->is_kind_of(C);
  (bless [],A)->is_kind_of(C);
  (bless [],A)->is_kind_of(bless [],C);

are all true.

=item ->subclass_responsibility()

If you have a method defined as

    sub meth {my($self) = @_; $self->subclass_responsibility()}

then this produces a fatal error message of the form:

Error: the method "meth" was called in class "A" by an object
of class "C" but should have been re-implemented in a subclass.

=item ->should_not_implement()

If you have a method defined as

    sub meth {my($self) = @_; $self->should_not_implement()}

then this produces a fatal error message of the form:

Error: the method "meth" was called in class "A" by an object
of class "C" but this method has been specifically disallowed.

=back

=head1 EXAMPLE

The following illustrates all functions, and can be executed
using C<perl -x Object/Info.pm>

#!perl
    

    package D;
    package A;
    package B;
    @ISA = qw(A);
    package C;
    @ISA = qw(B);
    sub new {bless []}
    package main;
    use Object::Info qw(superclasses is_kind_of is_object);
    sub test {
       my($obj,$meth,@args) = @_;
       print $meth,'(',join(',',$obj,@args),') gives "',
        	join(',',&$meth($obj,@args)),"\"\n";
    }
    
    test(C,'superclasses');			#superclasses(C)
    test(C->new(),'superclasses');		#superclasses(C->new())
    
#    test(C,'all_superclasses');		#all_superclasses(C)
#    test(C->new(),'all_superclasses');		#all_superclasses(C->new())

    test(C,'is_kind_of',C);			#is_kind_of(C,C)
    test(C,'is_kind_of',A);			#is_kind_of(C,A)
    test(C,'is_kind_of',D);			#is_kind_of(C,D)
    test(C->new(),'is_kind_of',C);		#is_kind_of(C->new(),C)
    test(C->new(),'is_kind_of',A);		#is_kind_of(C->new(),A)
    test(C->new(),'is_kind_of',D);		#is_kind_of(C->new(),D)
    
    test([],'is_object');			#is_object([])
    test(A,'is_object');			#is_object(A)
    test(C->new(),'is_object');			#is_object(C->new())



__END__

=head1 AUTHOR

Jack Shirazi

=head1 MODIFICATION HISTORY

Base version, 1.1, 19th October 1995 - JS.

The 'isa' was ripped out of UNIVERSAL in the interests of keeping
UNIVERSAL as basic as possible. In fact, one of the main reasons for
having the two methods that are in UNIVERSAL is to handle the special
case of FileHandles!

Here is the latest version of my Object:Info class with the hierarchy
trawl. Note that there are a couple of generic functions to trawl the
hierarchy taking a starting point class, and a test to perform on each
superclass. This allows easy customization of the hierarchy traversal.
Check the comment in 'uniquely_traverse_hierarchy'.

=cut