Bivio::UNIVERSAL
# 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;