Commit | Line | Data |
af6ca1d0 |
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; |
2f3efc97 |
57 | if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike. |
58 | s/([[:^print:]])/sprintf "\\x{%X}", ord $1/ge; |
59 | } else { |
60 | s/([^\0-\177])/sprintf "\\%03o", ord $1/ge; |
61 | } |
af6ca1d0 |
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) { |
2f3efc97 |
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 | } |
af6ca1d0 |
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 |