Commit | Line | Data |
---|---|---|
920dae64 AT |
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 | s/([^\0-\177])/sprintf "\\%03o", ord $1/ge; | |
58 | unless ($] < 5.006) { | |
59 | # This will elicit a warning on 5.005_03 about [: :] being reserved unless | |
60 | # I cheat | |
61 | my $cheat = '([[:^print:]])'; | |
62 | s/$cheat/sprintf "\\%03o", ord $1/ge; | |
63 | } else { | |
64 | require POSIX; | |
65 | s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; | |
66 | } | |
67 | $_; | |
68 | } | |
69 | ||
70 | =item perl_stringify NAME | |
71 | ||
72 | A function which returns a 7 bit ASCII correctly \ escaped version of the | |
73 | string passed suitable for a perl "" string. | |
74 | ||
75 | =cut | |
76 | ||
77 | # Hopefully make a happy perl identifier. | |
78 | sub perl_stringify { | |
79 | local $_ = shift; | |
80 | return unless defined $_; | |
81 | s/\\/\\\\/g; | |
82 | s/([\"\'])/\\$1/g; # Grr. fix perl mode. | |
83 | s/\n/\\n/g; # Ensure newlines don't end up in octal | |
84 | s/\r/\\r/g; | |
85 | s/\t/\\t/g; | |
86 | s/\f/\\f/g; | |
87 | s/\a/\\a/g; | |
88 | unless ($] < 5.006) { | |
89 | if ($] > 5.007) { | |
90 | s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge; | |
91 | } else { | |
92 | # Grr 5.6.1. And I don't think I can use utf8; to force the regexp | |
93 | # because 5.005_03 will fail. | |
94 | # This is grim, but I also can't split on // | |
95 | my $copy; | |
96 | foreach my $index (0 .. length ($_) - 1) { | |
97 | my $char = substr ($_, $index, 1); | |
98 | $copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char; | |
99 | } | |
100 | $_ = $copy; | |
101 | } | |
102 | # This will elicit a warning on 5.005_03 about [: :] being reserved unless | |
103 | # I cheat | |
104 | my $cheat = '([[:^print:]])'; | |
105 | s/$cheat/sprintf "\\%03o", ord $1/ge; | |
106 | } else { | |
107 | # Turns out "\x{}" notation only arrived with 5.6 | |
108 | s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge; | |
109 | require POSIX; | |
110 | s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; | |
111 | } | |
112 | $_; | |
113 | } | |
114 | ||
115 | 1; | |
116 | __END__ | |
117 | ||
118 | =back | |
119 | ||
120 | =head1 AUTHOR | |
121 | ||
122 | Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and | |
123 | others |