# Copyright (c) 1999-2007 bivio Software, Inc.  All rights reserved.
#
# Visit http://www.bivio.biz for more info.
# 
# This library is free software; you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation; either version 2.1 of the
# License, or (at your option) any later version.
# 
# This library is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Lesser General Public License for more details.
# 
# You should have received a copy of the GNU Lesser General Public
# License along with this library;  If not, you may get a copy from:
# http://www.opensource.org/licenses/lgpl-license.html
# 
# $Id: UNIVERSAL.pm,v 2.18 2007/03/24 19:17:43 nagler Exp $
package Bivio::UNIVERSAL;
use strict;

# C<Bivio::UNIVERSAL> is the base class for all bivio classes.  All of the
# methods defined here may be overriden.
#
# Please note the example use of L<new|"new">.

our($VERSION) = sprintf('%d.%02d', q$Revision: 0.0$ =~ /\d+/g);

sub as_string {
    # (self) : string
    # Returns the string form of I<self>.  By default, this is just I<self>.
    return shift(@_) . '';
}

sub die {
    # (proto, any, hash_ref) : undef
    # (proto, string, ...) : undef
    # A convenient alias for L<Bivio::Die::throw_or_die|Bivio::Die/"throw_or_die">
    shift;
    Bivio::Die->throw_or_die(@_);
    # DOES NOT RETURN
}

sub equals {
    # (self, UNIVERSAL) : boolean
    # Returns true if I<self> is identical I<that>.
    my($self, $that) = @_;
    return $self eq $that ? 1 : 0;
}

sub grep_methods {
    # (proto, regexp) : array_ref
    # Returns list of methods that match I<to_match>.  If a match is found, returns
    # $+ (last matching paren) if defined, otherwise returns complete method name.
    my($proto, $to_match) = @_;
    no strict 'refs';
    return $proto->use('Type.StringArray')->sort_unique([
	map($_ =~ $to_match ? defined($+) ? $+ : $_ : (),
	    map(keys(%{*{$_ . '::'}}),
	        $proto->package_name,
		@{$proto->inheritance_ancestors}))]);
}

sub inheritance_ancestors {
    # (self) : array_ref
    # Returns list of anscestors of I<class>, closest ancestor is at index 0.
    # Asserts single inheritance.  Must be descended from this class.
    my($proto) = @_;
    my($class) = ref($proto) || $proto;
    CORE::die('not a subclass of Bivio::UNIVERSAL')
	unless $class->isa(__PACKAGE__);
    # Broken if called from Bivio::UNIVERSAL
    my($res) = [];
    while ($class ne __PACKAGE__) {
	my($isa) = do {
	    no strict 'refs';
	    \@{$class . '::ISA'};
	};
	CORE::die($class, ': does not define @ISA')
	    unless @$isa;
	CORE::die($class, ': multiple inheritance not allowed; @ISA=', "@$isa")
	    unless int(@$isa) == 1;
	push(@$res, $class = $isa->[0]);
    }
    return $res;
}

sub instance_data_index {
    # (proto) : int
    # Returns the index into the instance data.  Usage:
    #
    #     my($_IDI) = __PACKAGE__->instance_data_index;
    #
    #     sub some_method {
    # 	my($self) = @_;
    # 	my($fields) = $self->[$_IDI];
    # 	...
    #     }
    my($pkg) = @_;
    # Some sanity checks, since we don't access this often
    CORE::die('must call statically from package body')
	unless $pkg eq (caller)[0];
    # This class doesn't have any instance data.
    return @{$pkg->inheritance_ancestors} - 1;
}

sub internal_data_section {
    # (proto) : string_ref
    # Reads the __DATA__ section of $proto.
    my($proto) = @_;
    no strict 'refs';
    return ${$proto->use('Bivio::IO::File')->read(
	\${$proto->package_name . '::'}{DATA})};
}

sub is_blessed {
    # (proto, any, any) : boolean
    # Returns true if I<value> is a blessed reference.  If I<object> supplied,
    # then test if I<value> isa I<object>.
    my(undef, $value, $object) = @_;
    my($v) = $value;
    return ref($value) && $v =~ /=/
	&& (!$object || $value->isa(ref($object) || $object)) ? 1 : 0;
}

sub map_by_two {
    # (proto, code_ref, array_ref) : array_ref
    # Passes I<values> two by two to I<op>.  Returns cummulative results
    # of I<op>.  If array is odd, last element will be C<undef>.
    my(undef, $op, $values) = @_;
    $values ||= [];
    return [map(
	$op->($values->[2 * $_], $values->[2 * $_ + 1]),
	0 .. int((@$values + 1) / 2) - 1,
    )];
}

sub map_invoke {
    # (proto, string, array_ref, array_ref, array_ref) : array_ref
    # (proto, code_ref, array_ref, array_ref, array_ref) : array_ref
    # Calls I<method> on I<self> with each element of I<args>.  If I<method> is a
    # ref, will call the sub.
    #
    # If the element of I<repeat_args> is an array, it will be unrolled as its
    # arguments.  Otherwise, the individual argument is called.  For example,
    #
    #     $math->map_invoke('add', [[1, 2], [3, 4]])
    #
    # returns
    #
    #     [3, 7]
    #
    # while
    #
    #     $math->map_invoke('add', [2, 3], [1])
    #
    # returns
    #
    #     [3, 4]
    #
    # and
    #
    #     $math->map_invoke('sub', [2, 3], undef, [1])
    #
    # returns
    #
    #     [1, 2]
    #
    # If I<method> takes a single array_ref as an argument, you need to wrap it
    # twice, e.g.
    #
    #     $string->map_invoke('concat', [[['a', 'b'], ['c', 'd']]])
    #
    # returns
    #
    #     ['ab', 'cd']
    #
    # Result is always called in an array context.
    my($proto, $method, $repeat_args, $first_args, $last_args) = @_;
    return [map(
	ref($method) ? $method->(@$_) : $proto->$method(@$_),
	map([
	    $first_args ? @$first_args : (),
	    ref($_) eq 'ARRAY' ? @$_ : $_,
	    $last_args ? @$last_args : (),
	], @$repeat_args),
    )];
}

sub my_caller {
    # (proto) : string
    # Returns method (or simple subroutine) name of caller immediately before the
    # caller of this routine.
    #
    # IMPLEMENTATION RESTRICTION: Does not work for evals.
    return ((caller(2))[3] =~ /([^:]+)$/)[0];
}

sub name_parameters {
    # (proto, array_ref, array_ref) : (self, hash_ref)
    # Expects I<names> to be the keys in the first and only element of I<argv>, or
    # uses I<names> to convert positional I<argv> into hash_ref.  Does not work if
    # first positional parameter is allowed to be a hash_ref.
    #
    # Returns (self, named).
    my($self, $names, $argv) = @_;
    my($map) = {map(($_ => 1), @$names)};
    my($named) = @$argv;
    if (ref($named) eq 'HASH') {
	Bivio::Die->die('Too many parameters: ', $argv)
	    unless @$argv == 1;
	Bivio::Die->die(
	    $named, ': unknown params passed to ',
	    (caller(1))[3], ', which only accepts ', $names,
	) if grep(!$map->{$_}, keys(%$named));
        # make a copy to avoid changing the caller's value
        $named = {%$named};
    }
    else {
	Bivio::Die->die($argv, ': too many params passed to ', (caller(1))[3])
	    unless @$argv <= @$names;
	my(@x) = @$names;
	$named = {map((shift(@x) => $_), @$argv)};
    }
    return ($self, $named);
}

sub new {
    # (proto, string) : Bivio.UNIVERSAL
    # Creates and blesses the object.
    #
    # This is how you should always create objects:
    #
    #     my($_IDI) = __PACKAGE__->instance_data_index;
    #
    #     sub new {
    #         my($proto) = shift;
    #         my($self) = $proto->SUPER::new(@_);
    # 	$self->[$_IDI] = {'field1' => 'value1'};
    # 	return $self;
    #     }
    #
    # All instances in Bivio's object space use this form.  This is the
    # only "bless" in the system.  There are several advantages of this.
    # Firstly, bless is inefficient and reblessing is an unnecessary
    # operation.  Secondly, all object creations go through this one
    # method, so we can track object allocations by adding just a little
    # bit of code.  Finally, the instance data name space is managed
    # effectively.  See L<instance_data_index|"instance_data_index"> for
    # more details.
    #
    # You can assign anything to your class's part of the instance data array.
    # If you are concerned about performance, consider arrays or pseudo-hashes.
    my($proto) = @_;
    return bless([], ref($proto) || $proto);
}

sub package_name {
    # (proto) : string
    # Returns the package name for the class being called.
    my($proto) = @_;
    return ref($proto) || $proto;
}

sub package_version {
    # (proto) : float
    # Returns the value of the C<$VERSION> variable for I<proto>.  Will die
    # if no such version.
    {
	no strict 'refs';
	return ${\${shift->package_name . '::VERSION'}};
    };
}

sub simple_package_name {
    # (proto) : string
    # Returns the package name sans directory prefixes, e.g. the simple package
    # name for this class is C<UNIVERSAL>.
    return (shift->package_name =~ /([^:]+$)/)[0];
}

sub use {
    # (proto, string, ...) : string
    # An convenient alias for map_require (Bivio::IO::ClassLoader).
    shift;
    return Bivio::IO::ClassLoader->map_require(@_);
}

1;