1package ExtUtils::Constant::Utils; 2 3use strict; 4use vars qw($VERSION @EXPORT_OK @ISA $is_perl56); 5use 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 15ExtUtils::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 24ExtUtils::Constant::Utils packages up utility subroutines used by 25ExtUtils::Constant, ExtUtils::Constant::Base and derived classes. All its 26functions are explicitly exportable. 27 28=head1 USAGE 29 30=over 4 31 32=item C_stringify NAME 33 34A function which returns a 7 bit ASCII correctly \ escaped version of the 35string passed suitable for C's "" or ''. It will die if passed Unicode 36characters. 37 38=cut 39 40# Hopefully make a happy C identifier. 41sub 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 76A function which returns a 7 bit ASCII correctly \ escaped version of the 77string passed suitable for a perl "" string. 78 79=cut 80 81# Hopefully make a happy perl identifier. 82sub 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 1231; 124__END__ 125 126=back 127 128=head1 AUTHOR 129 130Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and 131others 132