view release on metacpan or  search on metacpan

parts/apicheck.pl  view on Meta::CPAN

    my $long_form_required = $f->{'flags'}{'o'} || $f->{'flags'}{'f'};

  my $stack = '';
  my @arg;
  my $aTHX = '';

    my $i = 1;  # Argument number
  my $ca;
  my $varargs = 0;

    # Loop through the function's args, building up the declarations
    for $ca (@{$f->{'args'}}) {
    my $a = $ca->[0];           # 1th is the name, 0th is its type
    if ($a eq '...') {
      $varargs = 1;
      push @arg, qw(VARarg1 VARarg2 VARarg3);
      last;
    }

        # Split this argument into its components.  The formal parameter name is
        # discarded; we're just interested in the type and its modifiers
    my($t, $p, $d) = $a =~ /^ (  (?: " [^"]* " )      # literal string type => $t
                               | (?: \w+ (?: \s+ \w+ )* )    # name of type => $t
                              )
                              \s*
                              ( \** )                 # optional pointer(s) => $p
                              (?: \s* \b const \b \s* )? # opt. const
                              ( (?: \[ [^\]]* \] )* )    # opt. dimension(s)=> $d
                            $/x
                     or die "$0 - cannot parse argument: [$a] in $short_form\n";

        # Replace a special argument type by something that will compile.
    if (exists $amap{$t}) {
            if ($p or $d) {
                die "$short_form had type '$t', which should have been the"
                  . " whole type.  Instead '$p' or '$d' was non-empty";
            }
      push @arg, $amap{$t};
      next;
    }

    # Certain types, like 'void', get remapped.
    $t = $tmap{$t} || $t;

    if ($t =~ / ^ " [^"]* " $/x) {  # Use the literal string, literally
      push @arg, $t;
    }
    else {
      my $v = 'arg' . $i++;     # Argument number
      push @arg, $v;
      my $no_const_n = $t;      # Get rid of any remaining 'const's
      $no_const_n =~ s/\bconst\b//g unless $p;

      # Declare this argument
      $stack .= "  static $no_const_n $p$v$d;\n";
    }
  }

  # Declare thread context for functions and macros that might need it.
  # (Macros often fail to say they don't need it.)
  unless ($Tflag) {
    $stack = "  dTHX;\n$stack";     # Harmless to declare even if not needed
    $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
  }

    # If this function is on the list of things that need extra declarations,
    # add them.
  if ($stack{$short_form}) {
    my $s = '';
    for (@{$stack{$short_form}}) {
      $s .= "  $_\n";
    }
    $stack = "$s$stack";
  }

  my $args = join ', ', @arg;
  my $prefix = "";

  my $rvt = $f->{'ret'};  # Type of return value

  # Replace generic 'type'
  $rvt = 'int' if defined $rvt && $rvt eq 'type';

  # Failure to specify a return type in the apidoc line means void
  $rvt = 'void' unless $rvt;

  # Remove const, as otherwise could declare something that is impossible to
  # set.
  $rvt =~ s/\bconst\b//g;

  my $ret;
  if ($void{$rvt}) {    # Certain return types are instead considered void
    $ret = $castvoid{$short_form} ? '(void) ' : '';
  }
  else {
    $stack .= "  $rvt rval;\n";
    $ret = $ignorerv{$short_form} ? '(void) ' : "rval = ";
  }

  my $THX_prefix = "";
  my $THX_suffix = "";

  # Add parens to functions that take an argument list, even if empty
  unless ($nflag) {
    $THX_suffix = "($aTHX$args)";
    $args = "($args)";
  }

  # Single trailing underscore in name means is a comma operator
  if ($short_form =~ /[^_]_$/) {
    $THX_suffix .= ' 1';
    $args .= ' 1';
  }

  # Single leading underscore in a few names means is a comma operator
  if ($short_form =~ /^ _[ adp] (?: THX | MY_CXT ) /x) {
    $THX_prefix = '1 ';
    $prefix = '1 ';
  }