view release on metacpan or  search on metacpan

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

                            $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
    }

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

}

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

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

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