UNIVERSAL.pm

# Copyright (c) 1999-2013 bivio Software, Inc.  All rights reserved.
# $Id$
package Bivio::UNIVERSAL;
use strict;

my($_A, $_R, $_SA, $_P, $_CL);
my($_CLASSLOADER_MAP_NAME) = {};

sub CLASSLOADER_MAP_NAME {
    my($proto) = @_;
    my($pkg) = $proto->package_name;
    return $_CLASSLOADER_MAP_NAME->{$pkg}
        ||= _classloader()->unsafe_map_for_package($pkg);
}

sub as_classloader_map_name {
    my($proto) = @_;
    return ($proto->CLASSLOADER_MAP_NAME || return $proto->package_name)
        . '.'
        . $proto->simple_package_name;
}

sub as_classloader_mapped_package {
    my($proto) = @_;
    return $proto->use($proto->as_classloader_map_name);
}

sub as_req_key_value_list {
    my($proto) = @_;
    my($pkg) = $proto->package_name;
    return (
        $proto->as_classloader_map_name => $proto,
        $pkg => $proto,
    );
}

sub as_string {
    my($self) = @_;
    return "$self"
        unless $self->can('internal_as_string');
    my($p) = $self->simple_package_name;
    return $p
        unless ref($self);
    # Don't recurse more than two levels in calls to this sub.  We
    # look back an arbitrary number of levels (10), because there's
    # nesting inside Alert->format_args.
    my($this_sub) = (caller(0))[3];
    my($recursion) = 0;
    for (my($i) = 1; $i < 20; $i++) {
        my($sub) = (caller($i))[3];
        last unless $sub;
        return "$p(...)"
            if $this_sub eq $sub && ++$recursion >= 1;
    }
    my(@cfg) = map(($_, ','), $self->internal_as_string);
    pop(@cfg);
    my($res) = ($_A ||= $self->use('IO.Alert'))
        ->format_args($p, @cfg ? ('(', @cfg, ')') : ());
    chomp($res);
    return $res;
}

sub b_can {
    my($proto, $method, $object) = @_;
    $object ||= $proto;
    return defined($method) && !ref($method)
        && __PACKAGE__->is_super_of($object) && $object->can($method) ? 1 : 0;
}

sub boolean {
    return $_[1] ? 1 : 0;
}

sub call_and_do_after {
    my($proto, $op_or_method, $args, $do_after) = @_;
    my($op) = sub {ref($op_or_method) ? $op_or_method->(@$args) : $proto->$op_or_method(@$args)};
    if (wantarray) {
        my($res) = [$op->()];
        $do_after->($res, 1);
        return @$res;
    }
    if (defined(wantarray)) {
        my($res) = scalar($op->());
        $do_after->(\$res, 0);
        return $res;
    }
    $op->();
    $do_after->(undef, undef);
    return;
}

sub clone {
    my($self) = @_;
    return $self
        if $self->clone_return_is_self;
    $_R ||= $self->use('IO.Ref');
    my($clone) = bless([], ref($self));
    $_R->nested_copy_notify_clone($self, $clone);
    @$clone = map($_R->nested_copy($_), @$self);
    return $clone;
}

sub clone_return_is_self {
    return 0;
}

sub delegate_method {
    my($delegator, $delegate) = (shift, shift);
#     my($args) = [$proto->delegated_args(@_)];
#     # remove $delegate (see delegated_args)
#     shift(@$args);
#     return shift->$method(\&delegate_method, @$args);
    my($delegation) = $delegate->use('Bivio.Delegation')->new(
        $delegate, $delegator);
    my($method) = $delegation->get('method');
    return $delegate->$method(
        \&delegate_method,
        $delegation,
        $delegator,
        @_,
    );
}

sub delegated_args {
    my($delegate) = shift;
    return (
        $delegate->use('Bivio.Delegation')->new($delegate, $delegate),
        $delegate,
        @_,
    ) unless ref($_[0]) && $_[0] == \&delegate_method;
    shift;
    return @_;
}

sub delete_from_req {
    my($self, $req) = @_;
    # Also deletes instance as string so just reuse as_req_key_value_list
    $req->delete($self->as_req_key_value_list);
    return;
}

sub die {
    shift;
    Bivio::Die->throw_or_die(
        Bivio::IO::Alert->calling_context,
        @_,
    );
    # DOES NOT RETURN
}

sub do_by_two {
    my(undef, $op, $values) = @_;
    foreach my $i (0 .. int((@$values + 1) / 2) - 1) {
        last
            unless $op->($values->[2 * $i], $values->[2 * $i + 1], $i);
    }
    return;
}

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

sub equals_class_name {
    my($proto, $class) = @_;
    return $proto->boolean(
        $proto->is_simple_package_name($class)
            ? $proto->simple_package_name eq $class
            : _classloader()->is_valid_map_class_name($class)
            ? $proto->as_classloader_map_name eq $class
            : $proto->package_name eq $class,
    );
}

sub global_variable_ref {
    my($proto, $var_name) = @_;
    no strict 'refs';
    return \${$proto->package_name . '::' . $var_name};
}

sub grep_methods {
    my($proto) = shift;
    return _grep_sub($proto, $proto->inheritance_ancestors, @_);
}

sub grep_subroutines {
    my($proto) = shift;
    return _grep_sub($proto, undef, @_);
}

sub if_then_else {
    my($proto, $condition, $then, $else) = @_;
    $then = 1
        unless @_ >= 3;
    return ref($then) eq 'CODE' ? $then->($proto) : $then
        if ref($condition) eq 'CODE' ? $condition->($proto) : $condition;
    return
        unless @_ >= 4;
    return ref($else) eq 'CODE' ? $else->($proto) : $else;
}

sub inheritance_ancestors {
    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 {
    my($pkg) = @_;
    # Returns the index into the instance data.  Usage:
    #
    #     my($_IDI) = __PACKAGE__->instance_data_index;
    #
    #     sub some_method {
    #         my($self) = @_;
    #         my($fields) = $self->[$_IDI];
    #         ...
    #     }
    # 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 {
    my($proto, $op) = @_;
    no strict 'refs';
    my($f) = $proto->use('IO.File');
    my($h) = \${$proto->package_name . '::'}{DATA};
    return $op ? $f->do_lines($h, $op) : ${$f->read($h)};
}

sub internal_verify_do_iterate_result {
    my($proto, $value) = @_;
    $proto->use('IO.Alert')->warn(
        $value,
        ': handler must return 0 or 1; caller=',
        $proto->my_caller(1),
    ) unless defined($value) && $value =~ /^(?:0|1)$/;
    return $value;
}

sub is_blessed {
    return shift->is_blesser_of(@_);
}

sub is_blesser_of {
    my($proto, $value, $object) = @_;
    $object ||= $proto;
    my($v) = $value;
    return ref($value) && $v =~ /=/ && $object->is_super_of($value) ? 1 : 0;
}

sub is_private_method_name {
    my(undef, $method) = @_;
    return $method && $method =~ /^_/ ? 1 : 0;
}

sub is_simple_package_name {
    my(undef, $name) = @_;
    return $name =~ /^\w+$/ ? 1 : 0;
}

sub is_subclass {
    Bivio::IO::Alert->warn_deprecated('use is_super_of');
    return shift->is_super_of(@_);
}

sub is_super_of {
    my($proto, $other) = @_;
    return defined($other) && UNIVERSAL::isa($other, ref($proto) || $proto)
        ? 1 : 0;
}

sub iterate_reduce {
    my($proto, $op, $values, $initial) = @_;
    my($start) = 0;
    unless (defined($initial)) {
        $initial = $values->[0];
        $start++;
    }
    foreach my $i ($start .. $#$values) {
        $initial = $op->($initial, $values->[$i]);
    }
    return $initial;
}

sub list_if_value {
    my($proto) = shift;
    return @{$proto->map_by_two(sub {
        my($k, $v) = @_;
        return defined($v) ? ($k, $v) : ();
    }, \@_)};
}

sub map_by_slice {
    my($self, $op, $values, $slice_size) = @_;
    $slice_size ||= 2;
    return [map(
        {
            my($i) = $slice_size * $_;
            $op->(
                @$values[$i .. ($i + $slice_size - 1)],
                $_,
            );
        }
        0 .. int((@$values + 1) / $slice_size) - 1,
    )];
}

sub map_by_two {
    my($proto, $op, $values) = @_;
    unless (ref($values) eq 'ARRAY') {
        Bivio::IO::Alert->warn_deprecated('values must be an array ref');
        $values = [];
    }
    return $proto->map_by_slice($op, $values);
}

sub map_invoke {
    my($proto, $method, $repeat_args, $first_args, $last_args) = @_;
    # 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.
    return [map(
        ref($method) ? $method->(@$_) : $proto->$method(@$_),
        map([
            $first_args ? @$first_args : (),
            ref($_) eq 'ARRAY' ? @$_ : $_,
            $last_args ? @$last_args : (),
        ], @$repeat_args),
    )];
}

sub map_together {
    my($proto, $op, @arrays) = @_;
    return [map({
        my($i) = $_;
        $op->(map($_->[$i], @arrays));
    } 0 .. $proto->max_number(map($#$_, @arrays)))];
}

sub max_number {
    my(undef, @values) = @_;
    my($max) = shift(@values);
    foreach my $v (@values) {
        $max = $v
            if $max < $v;
    }
    return $max;
}

sub method_that_does_nothing {
    return;
}

sub my_caller {
    my(undef, $depth) = @_;
    # IMPLEMENTATION RESTRICTION: Does not work for evals.
    return ((caller(($depth || 0) + 2))[3] =~ /([^:]+)$/)[0];
}

sub name_parameters {
#TODO:    ($_A ||= __PACKAGE__->use('IO.Alert'))->warn_deprecated('use parameters');
    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 {
#TODO: Use ?syntax for optional params
#TODO: Consider combining with SheelUtil->name_arguments
        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 {
    my($proto) = @_;
    # 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.
    return bless([], ref($proto) || $proto);
}

sub package_name {
    my($proto) = @_;
    return ref($proto) || $proto;
}

sub parameters {
    return ($_P ||= __PACKAGE__->use('Bivio.Parameters'))
        ->process_via_universal(@_);
}

sub put_on_req {
    my($self, $req, $durable) = @_;
    Bivio::Die->die($self, ': self must be instance')
        unless ref($self);
    my($method) = $durable ? 'put_durable' : 'put';
    ($req || $self->req)->$method($self->as_req_key_value_list);
    return $self;
}

sub put_on_request {
    return shift->put_on_req(@_);
}

sub replace_subroutine {
    my($proto, $method, $code_ref) = @_;
    no strict 'refs';
    local($^W);
    # $proto->package_name does not work during import of Bivio::Base
    *{(ref($proto) || $proto) . '::' . $method} = $code_ref;
    return;
}

sub req {
    return _ureq(get_nested => @_);
}

sub return_scalar_or_array {
    my($proto) = shift;
    return wantarray ? @_
        : @_ <= 1 ? $_[0]
        : Bivio::Die->die(
            $proto->my_caller,
            ': method must be called in array context');
}

sub self_from_req {
    my($proto) = shift;
    return $proto->unsafe_self_from_req(@_)
        || Bivio::Die->die($proto, ': not on request');

}

sub simple_package_name {
    return (shift->package_name =~ /([^:]+$)/)[0];
}

sub type {
    my($proto, $class) = (shift, shift);
    $class = $proto->use('Type', $class);
    return @_ ? $class->from_literal_or_die(@_) : $class;
}

sub unsafe_get_request {
    return __PACKAGE__->is_super_of('Bivio::Agent::Request')
        ? __PACKAGE__->use('Agent.Request')->get_current : undef;
}

sub unsafe_self_from_req {
    my($proto, $req) = @_;
    # It's really unsafe_self_from_req_or_proto, but this is a common pattern.
    return $req ? $req->unsafe_get($proto->as_classloader_map_name)
        : $proto;
}

sub ureq {
    return _ureq(unsafe_get_nested => @_);
}

sub use {
    shift;
    return _classloader()->map_require(@_);
}

sub want_scalar {
    shift;
    return shift;
}

sub _classloader {
    return $_CL ||= Bivio::IO::ClassLoader->map_require('IO.ClassLoader');
}

sub _grep_sub {
    my($proto, $ancestors, $to_match) = @_;
    no strict 'refs';
    return ($_SA ||= $proto->use('Type.StringArray'))->sort_unique([
        map($_ =~ $to_match ? defined($+) ? $+ : $_ : (),
            map(
                {
                    my($stab) = \%{$_ . '::'};
                    grep(
                        !ref($stab->{$_}) && ref(*{$stab->{$_}}{CODE}) eq 'CODE',
                        keys(%$stab),
                    );
                }
                $proto->package_name,
                $ancestors ? @$ancestors : (),
            ),
        ),
    ]);
}

sub _ureq {
    my($method, $proto, @args) = @_;
    my($req) = ref($proto) && $proto->can('get_request') && $proto->get_request
        || Bivio::Agent::Request->get_current
        || Bivio::Die->die('no request');
    return @args ? $req->$method(@args) : $req
}

1;