view release on metacpan or  search on metacpan

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

                    $o->add_list($o->{ILSM}, $key, $filter_factory->(@args), []);
                }
                else {
                    eval { require Inline::Filters };
                    croak "'FILTERS' option requires Inline::Filters to be installed."
                        if $@;
                    %filters = Inline::Filters::get_filters($o->{API}{language})
                        unless keys %filters;
                    if (defined $filters{$val}) {
                        my $filter = Inline::Filters->new(
                            $val,
                                                          $filters{$val});
                        $o->add_list($o->{ILSM}, $key, $filter, []);
                    }
                    else {
                        croak "Invalid filter $val specified.";
                    }
                }
            }
            next;
        }
        if ($key eq 'STRUCTS') {
            # A list of struct names
            if (ref($value) eq 'ARRAY') {
                for my $val (@$value) {
                    croak "Invalid value for 'STRUCTS' option"
                        unless ($val =~ /^[_a-z][_0-9a-z]*$/i);
                    $o->{STRUCT}{$val}++;
                }
            }
            # Enable or disable
            elsif ($value =~ /^\d+$/) {
                $o->{STRUCT}{'.any'} = $value;
            }
            # A single struct name
            else {
                croak "Invalid value for 'STRUCTS' option"
                    unless ($value =~ /^[_a-z][_0-9a-z]*$/i);
                $o->{STRUCT}{$value}++;
            }
            eval { require Inline::Struct };
            croak "'STRUCTS' option requires Inline::Struct to be installed."
                if $@;
            $o->{STRUCT}{'.any'} = 1;
            next;
        }
        if ($key eq 'PROTOTYPES') {
            $o->{CONFIG}{PROTOTYPES} = $value;
            next if $value eq 'ENABLE';
            next if $value eq 'DISABLE';
            die "PROTOTYPES can be only either 'ENABLE' or 'DISABLE' - not $value";
        }
        if ($key eq 'PROTOTYPE') {
            die "PROTOTYPE configure arg must specify a hash reference"
                unless ref($value) eq 'HASH';
            $o->{CONFIG}{PROTOTYPE} = $value;
            next;
        }
        if ($key eq 'CPPFLAGS') {
            # C preprocessor flags, used by Inline::Filters::Preprocess()
            next;
        }

        my $class = ref $o; # handles subclasses correctly.
        croak "'$key' is not a valid config option for $class\n";
    }
}

sub add_list {
    my $o = shift;
    my ($ref, $key, $value, $default) = @_;
    $value = [$value] unless ref $value eq 'ARRAY';
    for (@$value) {
        if (defined $_) {
            push @{$ref->{$key}}, $_;
        }
        else {
            $ref->{$key} = $default;
        }
    }
}

sub add_string {
    my $o = shift;
    my ($ref, $key, $value, $default) = @_;
    $value = [$value] unless ref $value;
    croak usage_validate($key) unless ref($value) eq 'ARRAY';
    for (@$value) {
        if (defined $_) {
            $ref->{$key} .= ' ' . $_;
        }
        else {
            $ref->{$key} = $default;
        }
    }
}

sub add_text {
    my $o = shift;
    my ($ref, $key, $value, $default) = @_;
    $value = [$value] unless ref $value;
    croak usage_validate($key) unless ref($value) eq 'ARRAY';
    for (@$value) {
        if (defined $_) {
            chomp;
            $ref->{$key} .= $_ . "\n";
        }
        else {
            $ref->{$key} = $default;
        }
    }
}

#==============================================================================
# Return a small report about the C code..
#==============================================================================
sub info {
    my $o = shift;
    return <<END if $o->{ILSM}{XSMODE};
No information is currently generated when using XSMODE.

END
    my $text = '';
    $o->preprocess;
    $o->parse;
    if (defined $o->{ILSM}{parser}{data}{functions}) {
        $text .= "The following Inline $o->{API}{language} function(s) have been successfully bound to Perl:\n";
        my $parser = $o->{ILSM}{parser};
        my $data = $parser->{data};
        for my $function (sort @{$data->{functions}}) {
            my $return_type = $data->{function}{$function}{return_type};
            my @arg_names = @{$data->{function}{$function}{arg_names}};
            my @arg_types = @{$data->{function}{$function}{arg_types}};
            my @args = map {$_ . ' ' . shift @arg_names} @arg_types;
            $text .= "\t$return_type $function(" . join(', ', @args) . ")\n";
        }
    }
    else {
        $text .= "No $o->{API}{language} functions have been successfully bound to Perl.\n\n";
    }
    $text .= Inline::Struct::info($o) if $o->{STRUCT}{'.any'};
    return $text;
}

sub config {
    my $o = shift;
}

#==============================================================================
# Parse and compile C code
#==============================================================================
my $total_build_time;
sub build {
    my $o = shift;

    if ($o->{CONFIG}{BUILD_TIMERS}) {
        eval {require Time::HiRes};
        croak "You need Time::HiRes for BUILD_TIMERS option:\n$@" if $@;
        $total_build_time = Time::HiRes::time();
    }
    my ($file, $lockfh);
    if (IS_WIN32) {
        #this can not look like a file path, or new() fails
        $file = 'Inline__C_' . $o->{API}{directory} . '.lock';
        $file =~ s/\\/_/g; #per CreateMutex on MSDN
        $lockfh = Win32::Mutex->new(0, $file) or die "lockmutex $file: $^E";
        $lockfh->wait(); #acquire, can't use 1 to new(), since if new() opens
        #existing instead of create new Muxtex, it is not acquired
    }
    else {
        $file = File::Spec->catfile($o->{API}{directory}, '.lock');
        open $lockfh, '>', $file or die "lockfile $file: $!";
        flock($lockfh, LOCK_EX) or die "flock: $!\n" if $^O !~ /^VMS|riscos|VOS$/;
    }
    $o->mkpath($o->{API}{build_dir});
    $o->call('preprocess', 'Build Preprocess');
    $o->call('parse', 'Build Parse');
    $o->call('write_XS', 'Build Glue 1');
    $o->call('write_Inline_headers', 'Build Glue 2');
    $o->call('write_Makefile_PL', 'Build Glue 3');
    $o->call('compile', 'Build Compile');
    if (IS_WIN32) {
        $lockfh->release or die "releasemutex $file: $^E";
    }
    else {
        flock($lockfh, LOCK_UN) if $^O !~ /^VMS|riscos|VOS$/;
    }
    if ($o->{CONFIG}{BUILD_TIMERS}) {
        $total_build_time = Time::HiRes::time() - $total_build_time;
        printf STDERR "Total Build Time: %5.4f secs\n", $total_build_time;
    }
}

sub call {
    my ($o, $method, $header, $indent) = (@_, 0);
    my $time;
    my $i = ' ' x $indent;
    print STDERR "${i}Starting $header Stage\n" if $o->{CONFIG}{BUILD_NOISY};
    $time = Time::HiRes::time()
        if $o->{CONFIG}{BUILD_TIMERS};

    $o->$method();

    $time = Time::HiRes::time() - $time
        if $o->{CONFIG}{BUILD_TIMERS};
    print STDERR "${i}Finished $header Stage\n" if $o->{CONFIG}{BUILD_NOISY};
    printf STDERR "${i}Time for $header Stage: %5.4f secs\n", $time
        if $o->{CONFIG}{BUILD_TIMERS};
    print STDERR "\n" if $o->{CONFIG}{BUILD_NOISY};
}

#==============================================================================
# Apply any
#==============================================================================
sub preprocess {
    my $o = shift;
    return if $o->{ILSM}{parser};
    $o->get_maps;
    $o->get_types;
    $o->{ILSM}{code} = $o->filter(@{$o->{ILSM}{FILTERS}});
}

#==============================================================================
# Parse the function definition information out of the C code
#==============================================================================
sub parse {
    my $o = shift;
    return if $o->{ILSM}{parser};
    return if $o->{ILSM}{XSMODE};
    my $parser = $o->{ILSM}{parser} = $o->get_parser;
    $parser->{data}{typeconv} = $o->{ILSM}{typeconv};
    $parser->{data}{AUTOWRAP} = $o->{ILSM}{AUTOWRAP};
    Inline::Struct::parse($o) if $o->{STRUCT}{'.any'};
    $parser->code($o->{ILSM}{code})
        or croak <<END;
Bad $o->{API}{language} code passed to Inline at @{[caller(2)]}
END
}

# Create and initialize a parser
sub get_parser {
    my $o = shift;
    Inline::C::_parser_test($o->{CONFIG}{DIRECTORY}, "Inline::C::get_parser called\n")
        if $o->{CONFIG}{_TESTING};
    require Inline::C::Parser::RecDescent;
    Inline::C::Parser::RecDescent::get_parser($o);
}

#==============================================================================
# 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) {

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

#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 { '' }
END
    close MF;
}

#==============================================================================
# Run the build process.
#==============================================================================
sub compile {
    my $o = shift;

    my $build_dir = $o->{API}{build_dir};
    my $cwd = &cwd;
    ($cwd) = $cwd =~ /(.*)/ if $o->UNTAINT;

    chdir $build_dir;
    # Run these in an eval block, so that we get to chdir back to
    # $cwd if there's a failure. (Ticket #81375.)
    eval {
        $o->call('makefile_pl', '"perl Makefile.PL"', 2);
        $o->call('make', '"make"', 2);
        $o->call('make_install', '"make install"', 2);
    };
    chdir $cwd;
    die if $@; #Die now that we've done the chdir back to $cwd. (#81375)
    $o->call('cleanup', 'Cleaning Up', 2);
}

sub makefile_pl {
    my ($o) = @_;
    my $perl;
    -f ($perl = $Config::Config{perlpath})
        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 ) );