local-lib5/lib/perl5/PPI/Util.pm

   1 package PPI::Util;
   2
   3 # Provides some common utility functions that can be imported
   4
   5 use strict;
   6 use Exporter     ();
   7 use Digest::MD5  ();
   8 use Params::Util qw{_INSTANCE _SCALAR0 _ARRAY0};
   9
  10 use vars qw{$VERSION @ISA @EXPORT_OK};
  11 BEGIN {
  12         $VERSION   = '1.206';
  13         @ISA       = 'Exporter';
  14         @EXPORT_OK = qw{_Document _slurp};
  15 }
  16
  17 # Alarms are used to catch unexpectedly slow and complex documents
  18 use constant HAVE_ALARM   => !  ( $^O eq 'MSWin32' or $^O eq 'cygwin' );
  19
  20 # 5.8.7 was the first version to resolve the notorious
  21 # "unicode length caching" bug. See RT #FIXME
  22 use constant HAVE_UNICODE => !! ( $] >= 5.008007 );
  23
  24 # Common reusable true and false functions
  25 # This makes it easy to upgrade many places in PPI::XS
  26 sub TRUE  () { 1  }
  27 sub FALSE () { '' }
  28
  29
  30
  31
  32
  33 #####################################################################
  34 # Functions
  35
  36 # Allows a sub that takes a L<PPI::Document> to handle the full range
  37 # of different things, including file names, SCALAR source, etc.
  38 sub _Document {
  39         shift if @_ > 1;
  40         return undef unless defined $_[0];
  41         require PPI::Document;
  42         return PPI::Document->new(shift) unless ref $_[0];
  43         return PPI::Document->new(shift) if _SCALAR0($_[0]);
  44         return PPI::Document->new(shift) if _ARRAY0($_[0]);
  45         return shift if _INSTANCE($_[0], 'PPI::Document');
  46         return undef;
  47 }
  48
  49 # Provide a simple _slurp implementation
  50 sub _slurp {
  51         my $file = shift;
  52         local $/ = undef;
  53         local *FILE;
  54         open( FILE, '<', $file ) or return "open($file) failed: $!";
  55         my $source = <FILE>;
  56         close( FILE ) or return "close($file) failed: $!";
  57         return \$source;
  58 }
  59
  60 # Provides a version of Digest::MD5's md5hex that explicitly
  61 # works on the unix-newlined version of the content.
  62 sub md5hex {
  63         my $string = shift;
  64         $string =~ s/(?:\015{1,2}\012|\015|\012)/\015/gs;
  65         Digest::MD5::md5_hex($string);
  66 }
  67
  68 # As above but slurps and calculates the id for a file by name
  69 sub md5hex_file {
  70         my $file    = shift;
  71         my $content = _slurp($file);
  72         return undef unless ref $content;
  73         $$content =~ s/(?:\015{1,2}\012|\015|\012)/\n/gs;
  74         md5hex($$content);
  75 }
  76
  77 1;