xref: /openbsd-src/gnu/usr.bin/perl/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Utils.pm (revision 5759b3d249badf144a6240f7eec4dcf9df003e6b)
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