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.01';
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  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
72A function which returns a 7 bit ASCII correctly \ escaped version of the
73string passed suitable for a perl "" string.
74
75=cut
76
77# Hopefully make a happy perl identifier.
78sub 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
1151;
116__END__
117
118=back
119
120=head1 AUTHOR
121
122Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
123others
124