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