[Summary view] [Print] [Text view]

   1  package ExtUtils::Constant::Utils;
   2  
   3  use strict;
   4  use vars qw($VERSION @EXPORT_OK @ISA $is_perl56);
   5  use Carp;
   6  
   7  @ISA = 'Exporter';
   8  @EXPORT_OK = qw(C_stringify perl_stringify);
   9  $VERSION = '0.01';
  10  
  11  $is_perl56 = ($] < 5.007 && $] > 5.005_50);
  12  
  13  =head1 NAME
  14  
  15  ExtUtils::Constant::Utils - helper functions for ExtUtils::Constant
  16  
  17  =head1 SYNOPSIS
  18  
  19      use ExtUtils::Constant::Utils qw (C_stringify);
  20      $C_code = C_stringify $stuff;
  21  
  22  =head1 DESCRIPTION
  23  
  24  ExtUtils::Constant::Utils packages up utility subroutines used by
  25  ExtUtils::Constant, ExtUtils::Constant::Base and derived classes. All its
  26  functions are explicitly exportable.
  27  
  28  =head1 USAGE
  29  
  30  =over 4
  31  
  32  =item C_stringify NAME
  33  
  34  A function which returns a 7 bit ASCII correctly \ escaped version of the
  35  string passed suitable for C's "" or ''. It will die if passed Unicode
  36  characters.
  37  
  38  =cut
  39  
  40  # Hopefully make a happy C identifier.
  41  sub C_stringify {
  42    local $_ = shift;
  43    return unless defined $_;
  44    # grr 5.6.1
  45    confess "Wide character in '$_' intended as a C identifier"
  46      if tr/\0-\377// != length;
  47    # grr 5.6.1 moreso because its regexps will break on data that happens to
  48    # be utf8, which includes my 8 bit test cases.
  49    $_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if $is_perl56;
  50    s/\\/\\\\/g;
  51    s/([\"\'])/\\$1/g;    # Grr. fix perl mode.
  52    s/\n/\\n/g;        # Ensure newlines don't end up in octal
  53    s/\r/\\r/g;
  54    s/\t/\\t/g;
  55    s/\f/\\f/g;
  56    s/\a/\\a/g;
  57    if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
  58        s/([[:^print:]])/sprintf "\\%03o", ord $1/ge;
  59    } else {
  60        s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
  61    }
  62    unless ($] < 5.006) {
  63      # This will elicit a warning on 5.005_03 about [: :] being reserved unless
  64      # I cheat
  65      my $cheat = '([[:^print:]])';
  66      s/$cheat/sprintf "\\%03o", ord $1/ge;
  67    } else {
  68      require POSIX;
  69      s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
  70    }
  71    $_;
  72  }
  73  
  74  =item perl_stringify NAME
  75  
  76  A function which returns a 7 bit ASCII correctly \ escaped version of the
  77  string passed suitable for a perl "" string.
  78  
  79  =cut
  80  
  81  # Hopefully make a happy perl identifier.
  82  sub perl_stringify {
  83    local $_ = shift;
  84    return unless defined $_;
  85    s/\\/\\\\/g;
  86    s/([\"\'])/\\$1/g;    # Grr. fix perl mode.
  87    s/\n/\\n/g;        # Ensure newlines don't end up in octal
  88    s/\r/\\r/g;
  89    s/\t/\\t/g;
  90    s/\f/\\f/g;
  91    s/\a/\\a/g;
  92    unless ($] < 5.006) {
  93      if ($] > 5.007) {
  94      if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
  95          s/([[:^print:]])/sprintf "\\x{%X}", ord $1/ge;
  96      } else {
  97          s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
  98      }
  99      } else {
 100        # Grr 5.6.1. And I don't think I can use utf8; to force the regexp
 101        # because 5.005_03 will fail.
 102        # This is grim, but I also can't split on //
 103        my $copy;
 104        foreach my $index (0 .. length ($_) - 1) {
 105          my $char = substr ($_, $index, 1);
 106          $copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char;
 107        }
 108        $_ = $copy;
 109      }
 110      # This will elicit a warning on 5.005_03 about [: :] being reserved unless
 111      # I cheat
 112      my $cheat = '([[:^print:]])';
 113      s/$cheat/sprintf "\\%03o", ord $1/ge;
 114    } else {
 115      # Turns out "\x{}" notation only arrived with 5.6
 116      s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge;
 117      require POSIX;
 118      s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
 119    }
 120    $_;
 121  }
 122  
 123  1;
 124  __END__
 125  
 126  =back
 127  
 128  =head1 AUTHOR
 129  
 130  Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
 131  others