view release on metacpan or  search on metacpan

utils/common.pl  view on Meta::CPAN

    error_check => ($name eq "glGetError") ? "" : qq{OGLM_CHECK_ERR("$name", )},
    avail_check => $avail_check,
    beforecall => '',
    retcap => ($isvoid ? '' : 'RETVAL = '),
    retnames => ($isvoid ? [] : ['$retval']),
    callarg_list => $callarg_list,
    error_check2 => ($name eq "glGetError") ? "" : qq{OGLM_CHECK_ERR("$name", )},
    aftercall => '',
    retout => ($isvoid ? '' : "\nOUTPUT:\n  RETVAL"),
  );
  my @ret = \%default;
  my %dynlang = %{ $s->{dynlang} || {} };
  return @ret if !@ptr_arg_inds or !%dynlang;
  my %pbinding = (%default, binding_name => $name . '_p',
    aliases => [ map "${_}_p", sort keys %{ $s->{aliases} || {} } ],
  );
  @ptr_arg_inds = grep $_ >= 0, @ptr_arg_inds;
  my %name2data = map +($_->[0] => $_), @argdata;
  my %name2parsed = map +($_->[0] => parse_ptr($_)), @argdata[@ptr_arg_inds];
  die "$name: undefined dynlang arg '$_'" for grep /^[a-z]/ && !exists $name2data{$_}, keys %dynlang;
  my %this = %pbinding;
  my $cleanup = delete $dynlang{CLEANUP} // '';
  my %indynlang = %dynlang;
  my %is_inarg = map +($_->[0]=>1), @argdata;
  if (my @outaslist = grep $indynlang{$_} =~ /\bOUTASLIST\b/, keys %indynlang) {
    die "$name: >1 OUTASLIST (@outaslist)" if @outaslist > 1;
    die "$name: no OUTASLIST len" unless my ($len) = $indynlang{$outaslist[0]} =~ /\bOUTASLIST:([^\s,]+)/;
    my $parsed = $name2parsed{$outaslist[0]};
    die "$name: no typefunc for $outaslist[0]" unless my $typefunc = typefunc($parsed->[0]);
    my $newfunc = 'newSV' . lc substr $typefunc, 0, 2;
    $dynlang{$outaslist[0]} = "OGLM_ALLOC($len,$parsed->[0],$outaslist[0])";
    $cleanup .= "free($outaslist[0]);";
    $dynlang{OUTPUT} = "OGLM_OUT_FINISH($outaslist[0],$len,$newfunc)";
    $this{retnames} = ["\@$outaslist[0]"];
  }
  my @sized = grep $indynlang{$_} =~ /\bSIZE\b/, keys %indynlang;
  my %arg2lenoverride;
  for my $arg (@sized) {
    die "$name: failed to get SIZE info from '$indynlang{$arg}'" unless
      my ($compsize_group, $compsize_from, $mult) =
        $indynlang{$arg} =~ /\bSIZE:([^:]+):([^,:\s]+)(?::([^,\s]+))?/;
    $mult ||= 1;
    my $parsed = $name2parsed{$arg};
    $arg2lenoverride{$arg} = ["${compsize_from}_count", "OGLM_SIZE_ENUM($compsize_group,$compsize_from,$mult)"];
    $dynlang{$arg} = "OGLM_ALLOC(${compsize_from}_count,$parsed->[0],$arg)";
  }
  die "$name: cannot have both RETVAL and OUTPUT" if $dynlang{OUTPUT} and $dynlang{RETVAL};
  if (my $retval = delete $dynlang{RETVAL}) {
    die "$name: dynlang RETVAL '$retval' not arg to function" if !defined $name2data{$retval};
    if (($name2data{$retval}[2]//'') eq '1') {
      $this{xs_rettype} = $name2parsed{$retval}[0];
      $this{aftercall} = "\n  RETVAL = $retval\[0];";
    } else {
      $this{xs_rettype} = delete $dynlang{RETTYPE} // $name2data{$retval}[1];
      $this{aftercall} = "\n  RETVAL = $retval;";
    }
    $this{retout} = "\nOUTPUT:\n  RETVAL";
    $this{retnames} = ["\$$retval"];
  } elsif (my $output = delete $dynlang{OUTPUT}) {
    $this{aftercall} = "\n  $output";
    $this{xs_code} = "PPCODE:\n";
  } elsif (grep $indynlang{$_} =~ /\bOUT(?:ARRAY|SCALAR)\b/, keys %indynlang) {
    my @retnames = map $indynlang{$_} =~ /\bOUTSCALAR\b/ ? ['$',$_] :
      $indynlang{$_} =~ /\bOUTARRAY\b/ ? ['\\@',$_] :
      (), grep $indynlang{$_}, map $_->[0], @argdata;
    $this{retnames} = [ $isvoid ? () : '$retval', map join('', @$_), @retnames ];
    $this{xs_code} = "PPCODE:\n";
    my $aftercall = "EXTEND(sp, ".(@{ $this{retnames} }).");";
    if (!$isvoid) {
      my $newval = $s->{restype} =~ /^\s*void\s*\*\s*$/ ? "newSViv(PTR2IV(RETVAL))" : "newSV".lc(substr typefunc($s->{restype}), 0, 2)."(RETVAL)";
      $aftercall .= "\n  mPUSHs($newval);";
    }
    for (@retnames) {
      my ($sigil, $arg) = @$_;
      delete $is_inarg{$arg};
      if ($sigil eq '\\@') {
        die "$name: no OUTARRAY len" unless my ($len) = $indynlang{$arg} =~ /\bOUTARRAY:([^\s,]+)/;
        my $parsed = $name2parsed{$arg};
        $dynlang{$arg} = "OGLM_ALLOC($len,$parsed->[0],$arg)";
        my $typefunc = typefunc($name2parsed{$arg}[0]);
        my $newfunc = "newSV".lc(substr $typefunc, 0, 2);
        my $makeav = "OGLM_PUSH_ARRAY($name, $newfunc, $arg, $len)";
        $aftercall .= "\n  $makeav";
        $cleanup .= "free($arg);";
      } else {
        delete $dynlang{$arg};
        my $newval;
        if ($name2parsed{$arg}[0] eq 'void' || is_stringtype($name2data{$arg}[1])) {
          my ($len) = $indynlang{$arg} =~ /\bOUTSCALAR:([^\s,]+)/;
          $len //= 0;
          $newval = "newSVpv($arg,$len)";
        } else {
          my $typefunc = typefunc($name2parsed{$arg}[0]);
          $newval = "newSV".lc(substr $typefunc, 0, 2)."($arg\[0])";
        }
        $aftercall .= "\n  mPUSHs($newval);";
      }
    }
    $this{aftercall} = "\n  $aftercall";
    $this{retout} = "";
  }
  delete @is_inarg{keys %dynlang};
  delete @is_inarg{grep !$name2parsed{$_}[1], keys %name2parsed};
  my %is_inarray;
  for my $arg (sort grep $indynlang{$_} =~ /\bINARRAY:/, keys %indynlang) {
    die "$name: no INARRAY len" unless my ($len) = $indynlang{$arg} =~ /\bINARRAY:([^\s,]+)/;
    $is_inarray{$arg} = $is_inarg{$arg} = 1;
    my $parsed = $name2parsed{$arg};
    my $typefunc = typefunc($parsed->[0]);
    $dynlang{$arg} = "OGLM_GET_ARRAY($arg, $parsed->[0], $typefunc, $len)";
    $cleanup .= "free($arg);";
  }
  my $beforecall = '';
  for my $get (sort grep $dynlang{$_} =~ /^</, keys %dynlang) {
    my $val = delete $dynlang{$get};
    $val =~ s#^<##;
    my ($getfunc) = $val =~ /^(\w+)/;
    $val =~ s#&(?![\{\(a-z])#&$get#;
    my $vardata = $name2data{$get};
    $beforecall .= "  $vardata->[1]$get;\n  $val;\n";
    if (my $glewImpl = $signatures->{$getfunc}{glewImpl}) {
      $this{avail_check} = join "", grep $_, $this{avail_check}, "  OGLM_AVAIL_CHECK($glewImpl, $getfunc)\n";
    }
  }
  for my $len (sort grep $dynlang{$_} =~ /\bLEN:/, keys %dynlang) {
    my $val = delete $dynlang{$len};
    die "$name: failed to parse LEN '$val'" unless my ($varname) = $val =~ /\bLEN:([^,\s]+)/;