File Coverage

blib/lib/PDL/PP/Signature.pm

Criterion	Covered	Total	%
statement	193	200	96.5
branch	51	66	77.2
condition	45	63	71.4
subroutine	38	39	97.4
pod	0	32	0.0
total	327	400	81.7

package # hide from PAUSE/MetaCPAN
  PDL::PP::Signature;

use strict; use warnings;
use PDL::PP::PdlParObj;
use PDL::PP::Dims;
use Carp;

=head1 NAME

PDL::PP::Signature - Internal module to handle signatures

=head1 DESCRIPTION

Internal module to handle signatures

=head1 SYNOPSIS

 use PDL::PP::Signature;

=cut

# Eliminate whitespace entries
sub nospacesplit {grep /\S/, split $_[0],$_[1]}

sub new {
  my ($type,$pars,$opname,$otherpars,$otherparsdefaults,$argorder) = @_;
  confess "$opname ArgOrder given defined but false value" if defined $argorder and !$argorder;
  my @objects = map PDL::PP::PdlParObj->new($_, $opname), nospacesplit ';',$pars;
  my $this = bless {
    Names=>[map $_->name, @objects], Objects=>{map +($_->name => $_), @objects},
    OtherParsDefaults=>$otherparsdefaults||{},
    ArgOrder=>$argorder,
  }, $type;
  my @objects_sorted = ((grep !$_->{FlagW}, @objects), (grep $_->{FlagW}, @objects));
  $objects_sorted[$_]{Number} = $_ for 0..$#objects_sorted;
  $this->{NamesSorted} = [ map $_->name, @objects_sorted ];
  $this->{DimsObj} = my $dimsobj = PDL::PP::PdlDimsObj->new;
  $_->add_inds($dimsobj) for @objects;
  @$this{qw(OtherNames OtherObjs OtherAnyOut OtherFlags)} = $this->_otherPars_nft($otherpars||'', $opname);
  $this->_validate($opname);
  my $i=0; $dimsobj->ind_obj($_)->set_index($i++) for sort $dimsobj->ind_names;
  $this;
}

sub _validate {
  my ($sig, $name) = @_;
  my ($argorder, $otherdefaults) = @$sig{qw(ArgOrder OtherParsDefaults)};
  if (!$argorder and
    keys(%$otherdefaults) != (my @other_args = @{ $sig->{OtherNames} })
  ) {
    my $default_seen = '';
    for (@other_args) {
      $default_seen = $_ if exists $otherdefaults->{$_};
      confess "$name got default-less arg '$_' after default-ful arg '$default_seen'"
        if $default_seen and !exists $otherdefaults->{$_};
    }
  }
  if ($argorder and ref $argorder) {
    my @names = @{ $sig->allnames(1, 1) };
    my %namehash = map +($_=>1), @names;
    delete @namehash{@$argorder};
    confess "$name ArgOrder missed params: ".join(' ', keys %namehash) if keys %namehash;
    my %orderhash = map +($_=>1), @$argorder;
    delete @orderhash{@names};
    confess "$name ArgOrder too many params: ".join(' ', keys %orderhash) if keys %orderhash;
    my %optionals = map +($_=>1), keys(%$otherdefaults), $sig->names_out, $sig->other_out;
    my $optional = '';
    for (@$argorder) {
      $optional = $_, next if exists $optionals{$_};
      confess "$name got mandatory argument '$_' after optional argument '$optional'"
        if $optional and !exists $optionals{$_};
    }
  }
}

sub _otherPars_nft {
    my ($sig,$otherpars,$opname) = @_;
    my $dimobjs = $sig && $sig->dims_obj;
    my (@names,%types,$type,$any_out,%allflags);
    for (nospacesplit(';',$otherpars)) {
	my (%flags);
	if (s/^\s*$PDL::PP::PdlParObj::sqbr_re\s*//) {
	  %flags = my %lflags = map +($_=>1), split /\s*,\s*/, my $opts = $1;
	  croak "pp_def($opname): Can't have both [io] and [o]" if $lflags{o} && $lflags{io};
	  my $this_out = delete($lflags{o}) || delete($lflags{io});
	  croak "pp_def($opname): Invalid options '$opts' in '$_'" if keys %lflags;
	  $any_out ||= $this_out;
	}
	if (/^\s*([^=]+?)\s*=>\s*(\S+)\s*$/) {
	    # support 'int ndim => n;' syntax
	    my ($ctype,$dim) = ($1,$2);
	    print "OtherPars: setting dim '$dim' from '$ctype'\n" if $::PP_VERBOSE;
	    $type = PDL::PP::CType->new($ctype);
	    $dimobjs->get_indobj_make($dim)->set_from($type);
	} else {
	    $type = PDL::PP::CType->new($_);
	}
	my $name = $type->protoname;
	croak "pp_def($opname): Invalid OtherPars name: $name"
	  if $PDL::PP::PdlParObj::INVALID_PAR{$name};
	push @names,$name;
	$types{$name} = $type;
	$types{"${name}_count"} = PDL::PP::CType->new("PDL_Indx ${name}_count") if $type->is_array;
	$allflags{$name} = \%flags;
    }
    (\@names,\%types,$any_out,\%allflags);
}

=head1 AUTHOR

Copyright (C) Tuomas J. Lukka 1997 ([e-mail]) and by Christian
Soeller ([e-mail]).
All rights reserved. There is no warranty. You are allowed
to redistribute this software / documentation under certain
conditions. For details, see the file COPYING in the PDL
distribution. If this file is separated from the PDL distribution,
the copyright notice should be included in the file.

=cut

sub names { $_[0]{Names} }
sub names_sorted { $_[0]{NamesSorted} }
sub names_sorted_tuples {
  my ($count, @names) = (0, @{$_[0]{NamesSorted}});
  map [$count++, $_[0]{Objects}{$_}{FlagTemp}, $_], @names;
}

sub objs { $_[0]{Objects} }
sub names_in { my $o=$_[0]->objs; grep !$o->{$_}{FlagOut} && !$o->{$_}{FlagTemp}, @{$_[0]{Names}} }
sub names_out { my $o=$_[0]->objs; grep $o->{$_}{FlagOut}, @{$_[0]{Names}} }
sub names_oca { my $o=$_[0]->objs; grep $o->{$_}{FlagCreateAlways}, @{$_[0]{Names}} }
sub names_out_nca { my $o=$_[0]->objs; grep $o->{$_}{FlagOut} && !$o->{$_}{FlagCreateAlways}, @{$_[0]{Names}} }
sub names_tmp { my $o=$_[0]->objs; grep $o->{$_}{FlagTemp}, @{$_[0]{Names}} }

sub dims_obj { $_[0]->{DimsObj} }
sub dims_init {
  my ($self) = @_;
  join "\n",
    (sort map $_->get_initdim, $self->{DimsObj}->ind_fromcomp),
    (sort map $_->get_initdim, $self->{DimsObj}->ind_notfromcomp);
}

sub othernames {
  my ($self, $omit_count, $with_xs, $except) = @_;
  $except ||= {};
  return $self->{OtherNames} if $omit_count && $omit_count > 0 && !keys %$except && $with_xs;
  return [] if $omit_count && $omit_count < 0;
  my $objs = $self->otherobjs;
  my @raw_names = grep !$except->{$_}, @{$self->{OtherNames}};
  @raw_names = map $objs->{$_}->is_array ? ($_, "${_}_count") : $_, @raw_names if !$omit_count;
  @raw_names = grep !$objs->{$_}{WasDollar}, @raw_names if !$with_xs;
  \@raw_names;
}
sub otherobjs { $_[0]{OtherObjs} }
sub other_any_out { $_[0]{OtherAnyOut} }
sub other_is_flag {
  my $flag = $_[2];
  my $has_count = (my $without_count = $_[1]) =~ s/_count$//;
  return $_[0]{OtherFlags}{$_[1]} && $_[0]{OtherFlags}{$_[1]}{$flag} if !$has_count;
  $_[0]{OtherFlags}{$without_count} && $_[0]{OtherFlags}{$without_count}{$flag};
}
sub other_is_output { &other_is_out || &other_is_io }
sub other_is_out { $_[0]->other_is_flag($_[1], 'o') }
sub other_out { grep $_[0]->other_is_out($_), @{$_[0]{OtherNames}} }
sub other_is_io { $_[0]->other_is_flag($_[1], 'io') }
sub other_io { grep $_[0]->other_is_io($_), @{$_[0]{OtherNames}} }

sub allnames { my ($self, $omit_count, $with_xs, $except) = @_; [
  ($omit_count && $omit_count < 0) ? (grep $self->{Objects}{$_}{FlagCreateAlways}, @{$self->{Names}}) :
  (grep +(!$except || !$except->{$_}) && !$self->{Objects}{$_}{FlagTemp}, @{$self->{Names}}),
  @{$self->othernames(@_[1..3])},
] }
sub allobjs {
  my $pdltype = PDL::PP::CType->new("pdl *__foo__");
  +{ ( map +($_,$pdltype), @{$_[0]{Names}} ), %{$_[0]->otherobjs} };
}
sub alldecls {
  my ($self, $omit_count, $indirect, $with_xs, $except) = @_;
  my $objs = $self->allobjs;
  my @names = @{$self->allnames($omit_count, $with_xs, $except)};
  $indirect = $indirect ? { map +($_=>$self->other_is_output($_)), @names } : {};
  map $objs->{$_}->get_decl($_, {VarArrays2Ptrs=>1,AddIndirect=>$indirect->{$_}}), @names;
}
sub getcomp {
  my ($self) = @_;
  my $objs = $self->otherobjs;
  my @names = @{$self->othernames(0)};
  my $indirect = { map +($_=>$self->other_is_output($_)), @names };
  join "\n", map "  $_;", grep $_, map $objs->{$_}->get_decl($_, {VarArrays2Ptrs=>1,AddIndirect=>$indirect->{$_}}), @names;
}
sub getfree {
  my ($self,$symbol) = @_;
  my $objs = $self->otherobjs;
  join '', map $objs->{$_}->get_free("\$$symbol($_)",
    { VarArrays2Ptrs => 1 }), @{$self->othernames(0)};
}
sub getcopy {
  my ($self, $to_pat) = @_;
  my $objs = $self->otherobjs;
  PDL::PP::indent(2, join '', map $objs->{$_}->get_copy($_,sprintf $to_pat,$_)."\n", @{$self->othernames(0)});
}

sub args_callorder {
  my ($self) = @_;
  my $argorder = $self->{ArgOrder};
  return $self->allnames(1, 1) if !$argorder;
  return $argorder if ref $argorder;
  my $otherdefaults = $self->{OtherParsDefaults};
  my %optionals = map +($_=>1), keys(%$otherdefaults);
  my @other_mand = grep !$optionals{$_} && !$self->other_is_out($_),
    my @other = @{$self->othernames(1, 1)};
  my @other_opt = grep $optionals{$_}, @other;
  [$self->names_in, @other_mand, @other_opt, $self->names_out, $self->other_out];
}

sub realdims {
  my $this = shift;
  [ map scalar @{$this->{Objects}{$_}{RawInds}}, @{$this->{Names}} ];
}

sub creating {
  my $this = shift;
  confess "you must perform a checkdims before calling creating"
    unless defined $this->{Create};
  return $this->{Create};
}

sub checkdims {
  my $this = shift;
  # we have to recreate to keep defaults currently
  $this->{Dims} = PDL::PP::PdlDimsObj->new;
  $this->{Objects}{$_}->add_inds($this->{Dims}) for @{$this->{Names}};
  my $n = @{$this->{Names}};
  confess "not enough pdls to match signature" unless $#_ >= $n-1;
  my @pdls = @_[0..$n-1];
  if ($PDL::debug) { print "args: ".
		     join(' ,',map { "[".join(',',$_->dims)."]," } @pdls)
		       . "\n"}
  my $i = 0;
  my @creating = map $this->{Objects}{$_}->perldimcheck($pdls[$i++]),
         @{$this->{Names}};
  $i = 0;
  for (@{$this->{Names}}) {
    push @creating, $this->{Objects}{$_}->getcreatedims
      if $creating[$i++];
  }
  $this->{Create} = \@creating;
  $i = 0;
  my $corr = 0;
  for (@{$this->{Names}}) {
    $corr = $this->{Objects}{$_}->finalcheck($pdls[$i++]);
    next unless $#$corr>-1;
    my ($j,$str) = (0,"");
    for (@$corr) {$str.= ":,"x($_->[0]-$j)."(0),*$_->[1],";
			$j=$_->[0]+1 }
    chop $str;
    $_[$i-1] = $pdls[$i-1]->slice($str);
  }
}

1;