App-PerlXLock

 view release on metacpan or  search on metacpan

inc/Inline/C.pm  view on Meta::CPAN

# Gather the path names of all applicable typemap files.
#==============================================================================
sub get_maps {
    my $o = shift;

    print STDERR "get_maps Stage\n" if $o->{CONFIG}{BUILD_NOISY};
    my $typemap = '';
    my $file;
    $file = File::Spec->catfile(
        $Config::Config{installprivlib},
        "ExtUtils",
        "typemap",
    );
    $typemap = $file if -f $file;
    $file = File::Spec->catfile(
        $Config::Config{privlibexp}
        ,"ExtUtils","typemap"
    );
    $typemap = $file
        if (not $typemap and -f $file);
    warn "Can't find the default system typemap file"
        if (not $typemap and $^W);

    unshift(@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}, $typemap) if $typemap;

    if (not $o->UNTAINT) {
        require FindBin;
        $file = File::Spec->catfile($FindBin::Bin,"typemap");
        if ( -f $file ) {
           push(@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}, $file);
        }
    }
}

#==============================================================================
# This routine parses XS typemap files to get a list of valid types to create
# bindings to. This code is mostly hacked out of Larry Wall's xsubpp program.
#==============================================================================
sub get_types {
    my (%type_kind, %proto_letter, %input_expr, %output_expr);
    my $o = shift;
    local $_;
    croak "No typemaps specified for Inline C code"
        unless @{$o->{ILSM}{MAKEFILE}{TYPEMAPS}};

    my $proto_re = "[" . quotemeta('\$%&*@;') . "]";
    foreach my $typemap (@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}) {
        next unless -e $typemap;
        # skip directories, binary files etc.
        warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
            unless -T $typemap;
        open(TYPEMAP, $typemap)
            or warn ("Warning: could not open typemap file '$typemap': $!\n"),
            next;
        my $mode = 'Typemap';
        my $junk = "";
        my $current = \$junk;
        while (<TYPEMAP>) {
            next if /^\s*\#/;
            my $line_no = $. + 1;
            if (/^INPUT\s*$/)   {$mode = 'Input';   $current = \$junk;  next}
            if (/^OUTPUT\s*$/)  {$mode = 'Output';  $current = \$junk;  next}
            if (/^TYPEMAP\s*$/) {$mode = 'Typemap'; $current = \$junk;  next}
            if ($mode eq 'Typemap') {
                chomp;
                my $line = $_;
                TrimWhitespace($_);
                # skip blank lines and comment lines
                next if /^$/ or /^\#/;
                my ($type,$kind, $proto) =
                    /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
                    warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
                $type = TidyType($type);
                $type_kind{$type} = $kind;
                # prototype defaults to '$'
                $proto = "\$" unless $proto;
                warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
                    unless ValidProtoString($proto);
                $proto_letter{$type} = C_string($proto);
            }
            elsif (/^\s/) {
                $$current .= $_;
            }
            elsif ($mode eq 'Input') {
                s/\s+$//;
                $input_expr{$_} = '';
                $current = \$input_expr{$_};
            }
            else {
                s/\s+$//;
                $output_expr{$_} = '';
                $current = \$output_expr{$_};
            }
        }
        close(TYPEMAP);
    }

    my %valid_types = map {($_, 1)} grep {
        defined $input_expr{$type_kind{$_}}
    } keys %type_kind;

    my %valid_rtypes = map {($_, 1)} (
        grep {
            defined $output_expr{$type_kind{$_}}
        } keys %type_kind
    ), 'void';

    $o->{ILSM}{typeconv}{type_kind} = \%type_kind;
    $o->{ILSM}{typeconv}{input_expr} = \%input_expr;
    $o->{ILSM}{typeconv}{output_expr} = \%output_expr;
    $o->{ILSM}{typeconv}{valid_types} = \%valid_types;
    $o->{ILSM}{typeconv}{valid_rtypes} = \%valid_rtypes;
}

sub ValidProtoString ($) {
    my $string = shift;
    my $proto_re = "[" . quotemeta('\$%&*@;') . "]";
    return ($string =~ /^$proto_re+$/) ? $string : 0;
}

sub TrimWhitespace {
    $_[0] =~ s/^\s+|\s+$//go;

inc/Inline/C.pm  view on Meta::CPAN

        if (defined($o->{CONFIG}{PROTOTYPE})) {
            %h = %{$o->{CONFIG}{PROTOTYPE}};
        }

        if (defined($h{$function})) {
            $XS .= "  PROTOTYPE: $h{$function}\n";
        }

        my $listargs = '';
        $listargs = pop @arg_names
            if (@arg_names and $arg_names[-1] eq '...');
        my $arg_name_list = join(', ', @arg_names);

        if ($return_type eq 'void') {
            if ($o->{CONFIG}{_TESTING}) {
                $XS .= <<END;
        PREINIT:
        PerlIO* stream;
        I32* temp;
        PPCODE:
        temp = PL_markstack_ptr++;
        $function($arg_name_list);
      stream = PerlIO_open(\"$dir/void_test\", \"a\");
      if (stream == NULL) warn(\"%s\\n\", \"Unable to open $dir/void_test for appending\");
        if (PL_markstack_ptr != temp) {
          PerlIO_printf(stream, \"%s\\n\", \"TRULY_VOID\");
          PerlIO_close(stream);
          PL_markstack_ptr = temp;
          XSRETURN_EMPTY; /* return empty stack */
        }
        PerlIO_printf(stream, \"%s\\n\", \"LIST_CONTEXT\");
        PerlIO_close(stream);
        return; /* assume stack size is correct */
END
            }
            else {
                $XS .= <<END;
        PREINIT:
        I32* temp;
        PPCODE:
        temp = PL_markstack_ptr++;
        $function($arg_name_list);
        if (PL_markstack_ptr != temp) {
          /* truly void, because dXSARGS not invoked */
          PL_markstack_ptr = temp;
          XSRETURN_EMPTY; /* return empty stack */
        }
        /* must have used dXSARGS; list context implied */
        return; /* assume stack size is correct */
END
            }
        }
        elsif ($listargs) {
            $XS .= <<END;
        PREINIT:
        I32* temp;
        CODE:
        temp = PL_markstack_ptr++;
        RETVAL = $function($arg_name_list);
        PL_markstack_ptr = temp;
        OUTPUT:
        RETVAL
END
        }
    }
    $XS .= "\n";
    return $XS;
}

#==============================================================================
# Generate the INLINE.h file.
#==============================================================================
sub write_Inline_headers {
    my $o = shift;

    open HEADER, "> ".File::Spec->catfile($o->{API}{build_dir},"INLINE.h")
        or croak;

    print HEADER <<'END';
#define Inline_Stack_Vars dXSARGS
#define Inline_Stack_Items items
#define Inline_Stack_Item(x) ST(x)
#define Inline_Stack_Reset sp = mark
#define Inline_Stack_Push(x) XPUSHs(x)
#define Inline_Stack_Done PUTBACK
#define Inline_Stack_Return(x) XSRETURN(x)
#define Inline_Stack_Void XSRETURN(0)

#define INLINE_STACK_VARS Inline_Stack_Vars
#define INLINE_STACK_ITEMS Inline_Stack_Items
#define INLINE_STACK_ITEM(x) Inline_Stack_Item(x)
#define INLINE_STACK_RESET Inline_Stack_Reset
#define INLINE_STACK_PUSH(x) Inline_Stack_Push(x)
#define INLINE_STACK_DONE Inline_Stack_Done
#define INLINE_STACK_RETURN(x) Inline_Stack_Return(x)
#define INLINE_STACK_VOID Inline_Stack_Void

#define inline_stack_vars Inline_Stack_Vars
#define inline_stack_items Inline_Stack_Items
#define inline_stack_item(x) Inline_Stack_Item(x)
#define inline_stack_reset Inline_Stack_Reset
#define inline_stack_push(x) Inline_Stack_Push(x)
#define inline_stack_done Inline_Stack_Done
#define inline_stack_return(x) Inline_Stack_Return(x)
#define inline_stack_void Inline_Stack_Void
END

    close HEADER;
}

#==============================================================================
# Generate the Makefile.PL
#==============================================================================
sub write_Makefile_PL {
    my $o = shift;
    $o->{ILSM}{xsubppargs} = '';
    my $i = 0;
    for (@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}) {
        $o->{ILSM}{xsubppargs} .= "-typemap \"$_\" ";
    }

    my %options = (
        VERSION => $o->{API}{version} || '0.00',
        %{$o->{ILSM}{MAKEFILE}},
        NAME => $o->{API}{module},
    );

    open MF, "> ".File::Spec->catfile($o->{API}{build_dir},"Makefile.PL")
        or croak;

    print MF <<END;
use ExtUtils::MakeMaker;
my %options = %\{
END

    local $Data::Dumper::Terse = 1;
    local $Data::Dumper::Indent = 1;
    print MF Data::Dumper::Dumper(\ %options);

    print MF <<END;
\};
WriteMakefile(\%options);

# Remove the Makefile dependency. Causes problems on a few systems.
sub MY::makefile { '' }

inc/Inline/C.pm  view on Meta::CPAN

        or ($perl = $^X)
        or croak "Can't locate your perl binary";
    $perl = qq{"$perl"} if $perl =~ m/\s/;
    $o->system_call("$perl Makefile.PL", 'out.Makefile_PL');
    $o->fix_make;
}
sub make {
    my ($o) = @_;
    my $make = $o->{ILSM}{MAKE} || $Config::Config{make}
        or croak "Can't locate your make binary";
    local $ENV{MAKEFLAGS} = $ENV{MAKEFLAGS} =~ s/(--jobserver-fds=[\d,]+)//
        if $ENV{MAKEFLAGS};
    $o->system_call("$make", 'out.make');
}
sub make_install {
    my ($o) = @_;
    my $make = $o->{ILSM}{MAKE} || $Config::Config{make}
        or croak "Can't locate your make binary";
    if ($ENV{MAKEFLAGS}) { # Avoid uninitialized warnings
        local $ENV{MAKEFLAGS} = $ENV{MAKEFLAGS} =~
            s/(--jobserver-fds=[\d,]+)//;
    }
    $o->system_call("$make pure_install", 'out.make_install');
}
sub cleanup {
    my ($o) = @_;
    my ($modpname, $modfname, $install_lib) =
        @{$o->{API}}{qw(modpname modfname install_lib)};
    if ($o->{API}{cleanup}) {
        $o->rmpath(
            File::Spec->catdir($o->{API}{directory},'build'),
            $modpname
        );
        my $autodir = File::Spec->catdir($install_lib,'auto',$modpname);
        my @files = ( ".packlist", map "$modfname.$_", qw( bs exp lib ) );
        my @paths = grep { -e } map { File::Spec->catfile($autodir,$_) } @files;
        unlink($_) || die "Can't delete file $_: $!" for @paths;
    }
}

sub system_call {
    my ($o, $cmd, $output_file) = @_;
    my $build_noisy = defined $ENV{PERL_INLINE_BUILD_NOISY}
        ? $ENV{PERL_INLINE_BUILD_NOISY}
        : $o->{CONFIG}{BUILD_NOISY};
    # test this functionality with:
    #perl -MInline=C,Config,BUILD_NOISY,1,FORCE_BUILD,1 -e "use Inline C => q[void inline_warner() { int *x = 2; }]"
    if (not $build_noisy) {
        $cmd = "$cmd > $output_file 2>&1";
    }
    ($cmd) = $cmd =~ /(.*)/ if $o->UNTAINT;
    system($cmd) == 0
        or croak($o->build_error_message($cmd, $output_file, $build_noisy));
}

sub build_error_message {
    my ($o, $cmd, $output_file, $build_noisy) = @_;
    my $build_dir = $o->{API}{build_dir};
    my $output = '';
    if (not $build_noisy and
        open(OUTPUT, $output_file)
    ) {
        local $/;
        $output = <OUTPUT>;
        close OUTPUT;
    }

    my $errcode = $? >> 8;
    $output .= <<END;

A problem was encountered while attempting to compile and install your Inline
$o->{API}{language} code. The command that failed was:
  \"$cmd\" with error code $errcode

The build directory was:
$build_dir

To debug the problem, cd to the build directory, and inspect the output files.

END
    if ($cmd =~ /^make >/) {
        for (sort keys %ENV) {
            $output .= "Environment $_ = '$ENV{$_}'\n" if /^(?:MAKE|PATH)/;
        }
    }
    return $output;
}

#==============================================================================
# This routine fixes problems with the MakeMaker Makefile.
#==============================================================================
my %fixes = (
    INSTALLSITEARCH => 'install_lib',
    INSTALLDIRS => 'installdirs',
    XSUBPPARGS => 'xsubppargs',
    INSTALLSITELIB => 'install_lib',
);

sub fix_make {
    use strict;
    my (@lines, $fix);
    my $o = shift;

    $o->{ILSM}{install_lib} = $o->{API}{install_lib};
    $o->{ILSM}{installdirs} = 'site';

    open(MAKEFILE, '< Makefile')
        or croak "Can't open Makefile for input: $!\n";
    @lines = <MAKEFILE>;
    close MAKEFILE;

    open(MAKEFILE, '> Makefile')
        or croak "Can't open Makefile for output: $!\n";
    for (@lines) {
        if (/^(\w+)\s*=\s*\S+.*$/ and
            $fix = $fixes{$1}
        ) {
            my $fixed = $o->{ILSM}{$fix};
            print MAKEFILE "$1 = $fixed\n";
        }
        else {
            print MAKEFILE;
        }
    }
    close MAKEFILE;