view release on metacpan or  search on metacpan

lib/C/Scan/Constants.pm  view on Meta::CPAN

package C::Scan::Constants;

use 5.008003;
use strict;
use warnings;
use Carp;

use ExtUtils::Constant;
use ModPerl::CScan;
use File::Temp qw( tempdir );
use File::Copy;
use File::Spec;
use File::Path;
use Data::Dumper;
use IO::File;
use Config;

require Exporter;

our @ISA = qw(Exporter);

# Our functions are pretty uniquely named, and intended for
# calling from Makefile.PL, so we simply export them be default.
our @EXPORT      = qw( extract_constants_from
                       write_constants_module );

our %EXPORT_TAGS = ( 'all' => [ @EXPORT ] );
our @EXPORT_OK   = ( @{ $EXPORT_TAGS{'all'} } );

our $VERSION = "1.020";
$VERSION = eval $VERSION;

# This module was originally written to support a custom pure-Perl
# build system named Blueprint.  If you know of or use Blueprint,
# this section will mean something to you.  If not, ignore it.
my $g_use_blueprint_sections;
BEGIN {
    # Initialize global variable(s)
    $g_use_blueprint_sections = 0;

    eval 'require Blueprint';

    unless ($@) {
        $g_use_blueprint_sections = 1;
    }

    # Now blueprint comment block protection is quietly enabled.
    # This will almost never be turned on.
}

# _get_constant_data_blobs_from()
#
# Internal function.
#
# Returns a two blobs of data from the supplied file:
#   ($defines,   <-- #define macros with no args
#    $typedefs)  <-- #typedef enum constants
sub _get_constant_data_blobs_from {
    my $file_to_relocate = shift;

    if ( ! -f $file_to_relocate ) {
        croak "$file_to_relocate does not appear to be accessible";
    }

    # Create a temp directory here.
    my $temp_scan_dir = tempdir( 'c_scan_const_XXXXX',
                                 DIR     => File::Spec->tmpdir(),
                                 CLEANUP => 1 )
        or die "Internal error: failed to create temp dir";

    # copy the file into it
    my $scan_file_basename = ( File::Spec->splitpath($file_to_relocate) )[2];
    my $relocated_file = File::Spec->catpath( '',
                                              $temp_scan_dir,
                                              $scan_file_basename );
    copy($file_to_relocate, $relocated_file)
        or croak "Could not copy $file_to_relocate to $relocated_file";

    # scan the file
    my $c_header_file = ModPerl::CScan->new( filename => $relocated_file );
    
    if ( !defined( $c_header_file ) ) {
        croak "Could not create ModPerl::CScan obj for $relocated_file";
    }

    # Ugly hack to fix ActivePerl config bomb, i.e. expectation that "cppstdin"
    # is the cpp we'll be using.  This assumes MinGW is installed, which we
    # attempted to enforce in the Makefile.PL.  It probably assumes more than
    # should be safely assumed about the return data structure from Data::Flow,
    # but it seems to work.
    if ( $^O =~ /MSWin/i ) {
        my $cur_cppstdin = $c_header_file->get('Cpp')->{cppstdin};
	my $cur_cc = $Config{cc};
	unless (     $cur_cppstdin =~ /$cur_cc/
	         and $cur_cppstdin =~ /\-E/ ) {
            $c_header_file->get('Cpp')->{cppstdin} = "$cur_cc -E";
	}
    }
    
    # Swallow STDERR temporarily
    open my $OLDERR, ">&", STDERR;
    close(STDERR);

	# Redirect temporarily to the bit bucket, but keep it open
	# to avoid conflicting in a -w environment such as under test.
    # TBD: Make this friendlier for non-*n[u|i]x systems.
    open *STDERR, ">", "/dev/null";

    # We only care about unadorned macros, i.e. "defines"
    my $defs     = $c_header_file->get("defines_no_args");
### These next lines represent possible future functionality ####
#    my $defs2    = $c_header_file->get("defines_maybe");
#    my $defs3    = $c_header_file->get("defines_full");
#    my $defs4    = $c_header_file->get("defines_args");
#    my $defs5    = $c_header_file->get("defines_no_args_full");
#    my $defs6    = $c_header_file->get("Defines");
##################################################################
    my $typedefs = $c_header_file->get("typedef_texts");


### For debugging only ######################################################
### NOTE: need to send STDERR somewhere other than /dev/null for these to
###       work as intended.
###
#    warn sprintf("[$file_to_relocate] defines_no_args = %s", Dumper($defs));
#    warn sprintf("[$file_to_relocate] defines_maybe = %s", Dumper($defs2));
#    warn sprintf("[$file_to_relocate] defines_full = %s", Dumper($defs3));
#    warn sprintf("[$file_to_relocate] defines_args = %s", Dumper($defs4));
#    warn sprintf("[$file_to_relocate] defines_no_args_full = %s", Dumper($defs5));
#    warn sprintf("[$file_to_relocate] Defines = %s", Dumper($defs6));
#    warn sprintf("[$file_to_relocate] enums = %s", Dumper($typedefs));
#############################################################################

    # Restore STDERR and close the temp filehandle for neatness.
    close STDERR;
    open STDERR, ">&", $OLDERR;
	close $OLDERR;

    # Return the file object returned from ModPerl::CScan->new()
    # Note: these may be empty (hashref, arrayref)
    return ($defs, $typedefs);
}




# extract_constants_from()
#
# Exported function.
#
# This function takes a list of C header (.h) files and returns a list
# of constants information suitable for supplying as the NAME parameter
# to ExtUtils::Constant.
sub extract_constants_from {
    my @c_header_paths = @_;         # full paths to each .h file to scan

    my @all_constants;

    C_HEADER_FILE:
    foreach my $c_header_file ( @c_header_paths ) {
        my ($defs,
            $typedefs) = _get_constant_data_blobs_from( $c_header_file );

        if ( ( !defined $defs ||
               (defined $defs && scalar( keys %$defs ) == 0) ) and
             ( !defined $typedefs ||
               (defined $typedefs && scalar @$typedefs == 0) ) ) {
            warn "WARNING: Found no constants in $c_header_file.";
            next C_HEADER_FILE;
        }

        # Do the messy enum extraction
        my @enums = _extract_enum_constants_from( $typedefs );

        # We convert the base filename into something we can use
        # to avoid the error of throwing away the "filename constant"
	# e.g.  #ifndef FOO_H_
	#       #define FOO_H_
	my $all_caps_basename = uc ( ( File::Spec->splitpath($c_header_file) )[2] );
	$all_caps_basename =~ s/[.]/_/g;

        # Consolidate all names found into a single list.
        # Note that we discard string constants.
        my @constant_names = ( @enums,
                               grep {
                                   my $defn = $_;

                                   # Toss header file identifiers, but only
				   # when they are *really* header file identifiers.
                                   ( $defn !~ /_H[_]?$/
				     or ($defn =~ /_H[_]?$/