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