view release on metacpan or  search on metacpan

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

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) {
        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);
    }

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

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

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

sub TidyType {
    local $_ = shift;
    s|\s*(\*+)\s*|$1|g;
    s|(\*+)| $1 |g;
    s|\s+| |g;
    TrimWhitespace($_);
    $_;
}

sub C_string ($) {
    (my $string = shift) =~ s|\\|\\\\|g;
    $string;
}

#==============================================================================
# Write the XS code
#==============================================================================
sub write_XS {
    my $o = shift;
    my $modfname = $o->{API}{modfname};
    my $module = $o->{API}{module};
    my $file = File::Spec->catfile($o->{API}{build_dir},"$modfname.xs");
    open XS, ">", $file or croak "$file: $!";
    if ($o->{ILSM}{XSMODE}) {
        warn <<END if $^W and  $o->{ILSM}{code} !~ /MODULE\s*=\s*$module\b/;
While using Inline XSMODE, your XS code does not have a line with

  MODULE = $module

You should use the Inline NAME config option, and it should match the
XS MODULE name.

END
        print XS $o->xs_code;
    }
    else {
        print XS $o->xs_generate;
    }
    close XS;
}

#==============================================================================
# Generate the XS glue code (piece together lots of snippets)
#==============================================================================
sub xs_generate {
    my $o = shift;
    return join '', (
        $o->xs_includes,
        $o->xs_struct_macros,
        $o->xs_code,
        $o->xs_struct_code,
        $o->xs_bindings,
        $o->xs_boot,
    );
}

sub xs_includes {
    my $o = shift;
    return $o->{ILSM}{AUTO_INCLUDE};
}

sub xs_struct_macros {
    my $o = shift;
    return $o->{STRUCT}{'.macros'};
}

sub xs_code {
    my $o = shift;
    return $o->{ILSM}{code};
}

sub xs_struct_code {
    my $o = shift;
    return $o->{STRUCT}{'.xs'};
}

sub xs_boot {
    my $o = shift;
    if (defined $o->{ILSM}{XS}{BOOT} and $o->{ILSM}{XS}{BOOT}) {
        return <<END;
BOOT:
$o->{ILSM}{XS}{BOOT}
END
    }
    return '';
}

sub xs_bindings {
    my $o = shift;
    my $dir = $o->{API}{directory};

    if ($o->{CONFIG}{_TESTING}) {
        my $file = "$dir/void_test";
        if (! -f $file) {
            warn "$file: $!" if !open(TEST_FH, '>', $file);
            warn "$file: $!" if !close(TEST_FH);
        }
    }

    my ($pkg, $module) = @{$o->{API}}{qw(pkg module)};
    my $prefix = (
        ($o->{ILSM}{XS}{PREFIX})
        ? "PREFIX = $o->{ILSM}{XS}{PREFIX}"
        : ''
    );

    my $prototypes = defined($o->{CONFIG}{PROTOTYPES})
        ? $o->{CONFIG}{PROTOTYPES}
        : 'DISABLE';

    my $XS = <<END;

MODULE = $module  PACKAGE = $pkg  $prefix

PROTOTYPES: $prototypes

END

    my $parser = $o->{ILSM}{parser};
    my $data = $parser->{data};

    warn(
        "Warning. No Inline C functions bound to Perl in ", $o->{API}{script},
        "\n" .
         "Check your C function definition(s) for Inline compatibility\n\n"
    ) if ((not defined$data->{functions}) and ($^W));

    for my $function (@{$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}};

        $XS .= join '', (
            "\n$return_type\n$function (",
            join(', ', @arg_names), ")\n"
        );

        for my $arg_name (@arg_names) {
            my $arg_type = shift @arg_types;
            last if $arg_type eq '...';
            $XS .= "\t$arg_type\t$arg_name\n";
        }

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