libwx-perl 1:0.9922-2 / usr / lib / perl5 / Wx / build / Utils.pm

package Wx::build::Utils;

use strict;
use Config;
use base 'Exporter';
use File::Spec::Functions qw(curdir catdir catfile updir);
use File::Find qw(find);
use File::Path qw(mkpath);
use File::Basename qw(dirname);
use Carp;

use vars qw(@EXPORT @EXPORT_OK);
@EXPORT_OK = qw(obj_from_src xs_dependencies write_string
                lib_file arch_file arch_auto_file
                path_search files_with_overload files_with_constants
                pipe_stderr read_file write_file);

=head1 NAME

Wx::build::Utils - utility routines

=head1 SUBROUTINES

=head2 xs_dependencies

  my %dependencies = xs_dependencies( $mm_object, [ 'dir1', 'dir2' ] );

=cut

sub _uniq {
    my( %x );
    $x{$_} = 1 foreach @_;
    return sort keys %x;
}

sub xs_dependencies {
  my( $this, $dirs, $top_dir ) = @_;

  my( %depend );
  my( $c, $o, $cinclude, $xsinclude );

  foreach ( keys %{ $this->{XS} } ) {
    ( $cinclude, $xsinclude ) = scan_xs( $_, $dirs, $top_dir );

    $c = $this->{XS}{$_};
    $o = obj_from_src( $c );

    $depend{$c} = $_ . ' ' . join( ' ', _uniq( @$xsinclude ) );
    $depend{$o} = $c . ' ' . join( ' ', _uniq( @$cinclude ) );
  }

  return %depend;
}

=head2 obj_from_src

  my @obj_files = obj_from_src( 'Foo.xs', 'bar.c', 'cpp/bar.cpp' );

Calculates the object file name from the source file name.
In scalar context returns the first file.

=cut

sub obj_from_src {
  my @xs = @_;
  my $obj_ext = $Config{obj_ext} || $Config{_o};

  foreach ( @xs ) { s[\.(?:xs|c|cc|cpp)$][$obj_ext] }

  return wantarray ? @xs : $xs[0];
}

sub src_dir {
  my( $file ) = @_;
  my $d = curdir;

  for ( 1 .. 5 ) {
    return $d if -f catfile( $d, $file );
    $d = catdir( updir, $d );
  }

  confess "Unable to find top level directory ($file)";
}

#
# quick and dirty method for creating dependencies:
# considers files included via #include "...", INCLUDE: or INCLUDE_COMMAND:
# (not #include <...>) and does not take into account preprocessor directives
#
sub scan_xs($$$);

sub scan_xs($$$) {
  my( $xs, $incpath, $top_dir ) = @_;

  local( *IN, $_ );
  my( @cinclude, @xsinclude );

  open IN, $xs;

  my $file;
  my $arr;

  while( defined( $_ = <IN> ) ) {
    undef $file;

    m/^\#\s*include\s+"([^"]*)"\s*$/ and $file = $1 and $arr = \@cinclude;
    m/^\s*INCLUDE:\s+(.*)$/ and $file = $1 and $arr = \@xsinclude;
    m/^\s*INCLUDE_COMMAND:\s+.*\s(\S+\.(?:xsp?|h))\s*/ and $file = $1 and
      $arr = \@xsinclude;
    m/^\s*\%include{([^}]+)}\s*;\s*$/ and $file = $1 and $arr = \@xsinclude;

    if( defined $file ) {
      $file = catfile( split '/', $file );

      foreach my $dir ( @$incpath ) {
        my $f = $dir eq curdir() ? $file : catfile( $dir, $file );
        if( -f $f ) {
          push @$arr, $f;
          my( $cinclude, $xsinclude ) = scan_xs( $f, $incpath, $top_dir );
          push @cinclude, @$cinclude;
          push @xsinclude, @$xsinclude;
          last;
        } elsif(    $file =~ m/ovl_const\.(?:cpp|h)/i
                 || $file =~ m/v_cback_def\.h/i
                 || $file =~ m/ItemContainer(?:Immutable)?\.xs/i
                 || $file =~ m/Var[VH]{0,2}ScrollHelper(?:Base)?\.xs/i ) {
          push @$arr, ( ( $top_dir eq curdir() ) ?
                        $file :
                        catfile( $top_dir, $file ) );
        }
      }
    }
  }

  close IN;

  ( \@cinclude, \@xsinclude );
}

=head2 write_string, write_file

  write_string( 'file', $scalar );
  write_file( 'file', $scalar );

Like File::Slurp.

=head2 read_file

  my $string = read_file( 'file' );

=cut

*write_string = \&write_file;

sub write_file {
  my( $file, $string ) = @_;

  mkpath( dirname( $file ) ) if dirname( $file );
  open my $fh, ">", $file or die "open '$file': $!";
  binmode $fh;
  print $fh $string or die "print '$file': $!";
  close $fh or die "close '$file': $!";
}

sub read_file {
  my( $file ) = @_;

  local $/ = wantarray ? $/ : undef;;
  open my $fh, "<", $file or die "open '$file': $!";
  binmode $fh;

  return <$fh>;
}

=head2 lib_file, arch_file, arch_auto_file

  my $file = lib_file( 'Foo.pm' );          # blib/lib/Foo.pm     on *nix
  my $file = lib_file( 'Foo/Bar.pm' );      # blib\lib\Foo\Bar.pm on Win32
  my $file = arch_auto_file( 'My\My.dll' ); # blib\arch\auto\My\My.dll

All input paths must be relative, output paths may be absolute.

=cut

sub _split {
  require File::Spec::Unix;

  my $path = shift;
  my( $volume, $dir, $file ) = File::Spec::Unix->splitpath( $path );
  my @dirs = File::Spec::Unix->splitdir( $dir );

  return ( @dirs, $file );
}

sub lib_file {
  my @split = _split( shift );

  return File::Spec->catfile( 'blib', 'lib', @split );
}

sub arch_file {
  my @split = _split( shift );

  return File::Spec->catfile( 'blib', 'arch', @split );
}

sub arch_auto_file {
  my @split = _split( shift );

  return File::Spec->catfile( 'blib', 'arch', 'auto', @split );
}

=head2 path_search

  my $file = path_search( 'foo.exe' );

Searches PATH for the given executable.

=cut

sub path_search {
  my $file = shift;

  foreach my $d ( File::Spec->path ) {
    my $full = File::Spec->catfile( $d, $file );
    return $full if -f $full;
  }

  return;
}

=head2 files_with_constants

  my @files = files_with_constants;

Finds files containing constants

=cut

sub files_with_constants {
  my @files;

  my $wanted = sub {
    my $name = $File::Find::name;

    m/\.(?:pm|xsp?|cpp|h)$/i && do {
      local *IN;
      my $line;

      open IN, "< $_" || warn "unable to open '$_'";
      while( defined( $line = <IN> ) ) {
        $line =~ m/^\W+\!\w+:/ && do {
          push @files, $name;
          return;
        };
        # for XS++ files containing enums, see comment in Any_OS.pm
        $line =~ m/^\s*enum\b/ && do {
          push @files, $name;
          return;
        };
      };
    };
  };

  find( $wanted, curdir );

  return @files;
}

=head2 files_with_overload

  my @files = files_with_overload;

Finds files containing overloaded XS/Perl subroutines

=cut

sub files_with_overload {
  my @files;

  my $wanted = sub {
    my $name = $File::Find::name;

    m/\.pm$/i && do {
      my $line;
      local *IN;

      open IN, "< $_" || warn "unable to open '$_'";
      while( defined( $line = <IN> ) ) {
        $line =~ m/Wx::_match/ && do {
          push @files, $name;
          return;
        };
      }
    };

    m/\.xsp?$/i && do {
      my $line;
      local *IN;

      open IN, "< $_" || warn "unable to open '$_'";
      while( defined( $line = <IN> ) ) {
        $line =~ m/wxPli_match_arguments|BEGIN_OVERLOAD\(\)/ && do {
          push @files, $name;
          return;
        };
      }
    };
  };

  find( $wanted, curdir );

  return @files;
}

sub pipe_stderr {
  my( $cmd ) = @_;
  my $pipe = File::Spec->catfile( 'script', 'pipe.pl' );

  if( -f $pipe ) {
    return qx{$^X $pipe $cmd};
  } else {
    # fix quoting later if necessary
    return qx[$^X -e "open STDERR, q{>&STDOUT}; exec q{$cmd}"];
  }
}

1;

# local variables:
# mode: cperl
# end: