cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Utils.pm

   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.02';
  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