This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Switch from Carp to plain old warn in vms/ext/XSSymSet.pm
[perl5.git] / vms / ext / XSSymSet.pm
CommitLineData
ff0cee69
PP
1package ExtUtils::XSSymSet;
2
ff0cee69
PP
3use strict;
4use vars qw( $VERSION );
5$VERSION = '1.0';
6
7
8sub new {
9 my($pkg,$maxlen,$silent) = @_;
10 $maxlen ||= 31;
11 $silent ||= 0;
12 my($obj) = { '__M@xLen' => $maxlen, '__S!lent' => $silent };
13 bless $obj, $pkg;
14}
15
16
17sub trimsym {
18 my($self,$name,$maxlen,$silent) = @_;
19
20 unless (defined $maxlen) {
21 if (ref $self) { $maxlen ||= $self->{'__M@xLen'}; }
22 $maxlen ||= 31;
23 }
24 unless (defined $silent) {
25 if (ref $self) { $silent ||= $self->{'__S!lent'}; }
26 $silent ||= 0;
27 }
28 return $name if (length $name <= $maxlen);
29
30 my $trimmed = $name;
31 # First, just try to remove duplicated delimiters
32 $trimmed =~ s/__/_/g;
33 if (length $trimmed > $maxlen) {
34 # Next, all duplicated chars
35 $trimmed =~ s/(.)\1+/$1/g;
36 if (length $trimmed > $maxlen) {
37 my $squeezed = $trimmed;
38 my($xs,$prefix,$func) = $trimmed =~ /^(XS_)?(.*)_([^_]*)$/;
39 if (length $func <= 12) { # Try to preserve short function names
40 my $frac = int(length $prefix / (length $trimmed - $maxlen) + 0.5);
41 my $pat = '([^_])';
42 if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; }
43 $prefix =~ s/$pat/$1/g;
44 $squeezed = "$xs$prefix" . "_$func";
45 if (length $squeezed > $maxlen) {
46 $pat =~ s/A-Z//;
47 $prefix =~ s/$pat/$1/g;
48 $squeezed = "$xs$prefix" . "_$func";
49 }
50 }
51 else {
52 my $frac = int(length $trimmed / (length $trimmed - $maxlen) + 0.5);
53 my $pat = '([^_])';
54 if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; }
55 $squeezed = "$prefix$func";
56 $squeezed =~ s/$pat/$1/g;
57 if (length "$xs$squeezed" > $maxlen) {
58 $pat =~ s/A-Z//;
59 $squeezed =~ s/$pat/$1/g;
60 }
61 $squeezed = "$xs$squeezed";
62 }
63 if (length $squeezed <= $maxlen) { $trimmed = $squeezed; }
64 else {
65 my $frac = int((length $trimmed - $maxlen) / length $trimmed + 0.5);
66 my $pat = '(.).{$frac}';
67 $trimmed =~ s/$pat/$1/g;
68 }
69 }
70 }
622db3b8 71 warn "Warning: long symbol $name\n\ttrimmed to $trimmed\n\t" unless $silent;
ff0cee69
PP
72 return $trimmed;
73}
74
75
76sub addsym {
77 my($self,$sym,$maxlen,$silent) = @_;
78 my $trimmed = $self->get_trimmed($sym);
79
80 return $trimmed if defined $trimmed;
81
82 $maxlen ||= $self->{'__M@xLen'} || 31;
83 $silent ||= $self->{'__S!lent'} || 0;
84 $trimmed = $self->trimsym($sym,$maxlen,1);
85 if (exists $self->{$trimmed}) {
86 my($i) = "00";
87 $trimmed = $self->trimsym($sym,$maxlen-3,$silent);
88 while (exists $self->{"${trimmed}_$i"}) { $i++; }
622db3b8 89 warn "Warning: duplicate symbol $trimmed\n\tchanged to ${trimmed}_$i\n\t(original was $sym)\n\t"
ff0cee69
PP
90 unless $silent;
91 $trimmed .= "_$i";
92 }
93 elsif (not $silent and $trimmed ne $sym) {
622db3b8 94 warn "Warning: long symbol $sym\n\ttrimmed to $trimmed\n\t";
ff0cee69
PP
95 }
96 $self->{$trimmed} = $sym;
97 $self->{'__N+Map'}->{$sym} = $trimmed;
98 $trimmed;
99}
100
101
102sub delsym {
103 my($self,$sym) = @_;
104 my $trimmed = $self->{'__N+Map'}->{$sym};
105 if (defined $trimmed) {
106 delete $self->{'__N+Map'}->{$sym};
107 delete $self->{$trimmed};
108 }
109 $trimmed;
110}
111
112
113sub get_trimmed {
114 my($self,$sym) = @_;
115 $self->{'__N+Map'}->{$sym};
116}
117
118
119sub get_orig {
120 my($self,$trimmed) = @_;
121 $self->{$trimmed};
122}
123
124
125sub all_orig { (keys %{$_[0]->{'__N+Map'}}); }
126sub all_trimmed { (grep { /^\w+$/ } keys %{$_[0]}); }
127
128__END__
129
130=head1 NAME
131
132VMS::XSSymSet - keep sets of symbol names palatable to the VMS linker
133
134=head1 SYNOPSIS
135
136 use VMS::XSSymSet;
137
138 $set = new VMS::XSSymSet;
139 while ($sym = make_symbol()) { $set->addsym($sym); }
140 foreach $safesym ($set->all_trimmed) {
141 print "Processing $safesym (derived from ",$self->get_orig($safesym),")\n";
142 do_stuff($safesym);
143 }
144
145 $safesym = VMS::XSSymSet->trimsym($onesym);
146
147=head1 DESCRIPTION
148
149Since the VMS linker distinguishes symbols based only on the first 31
150characters of their names, it is occasionally necessary to shorten
151symbol names in order to avoid collisions. (This is especially true of
152names generated by xsubpp, since prefixes generated by nested package
153names can become quite long.) C<VMS::XSSymSet> provides functions to
154shorten names in a consistent fashion, and to track a set of names to
155insure that each is unique. While designed with F<xsubpp> in mind, it
156may be used with any set of strings.
157
158This package supplies the following functions, all of which should be
159called as methods.
160
161=over 4
162
163=item new([$maxlen[,$silent]])
164
165Creates an empty C<VMS::XSSymset> set of symbols. This function may be
166called as a static method or via an existing object. If C<$maxlen> or
167C<$silent> are specified, they are used as the defaults for maximum
168name length and warning behavior in future calls to addsym() or
169trimsym() via this object.
170
171=item addsym($name[,$maxlen[,$silent]])
172
173Creates a symbol name from C<$name>, using the methods described
174under trimsym(), which is unique in this set of symbols, and returns
175the new name. C<$name> and its resultant are added to the set, and
176any future calls to addsym() specifying the same C<$name> will return
177the same result, regardless of the value of C<$maxlen> specified.
178Unless C<$silent> is true, warnings are output if C<$name> had to be
179trimmed or changed in order to avoid collision with an existing symbol
180name. C<$maxlen> and C<$silent> default to the values specified when
181this set of symbols was created. This method must be called via an
182existing object.
183
184=item trimsym($name[,$maxlen[,$silent]])
185
186Creates a symbol name C<$maxlen> or fewer characters long from
187C<$name> and returns it. If C<$name> is too long, it first tries to
188shorten it by removing duplicate characters, then by periodically
189removing non-underscore characters, and finally, if necessary, by
190periodically removing characters of any type. C<$maxlen> defaults
191to 31. Unless C<$silent> is true, a warning is output if C<$name>
192is altered in any way. This function may be called either as a
193static method or via an existing object, but in the latter case no
194check is made to insure that the resulting name is unique in the
195set of symbols.
196
197=item delsym($name)
198
199Removes C<$name> from the set of symbols, where C<$name> is the
200original symbol name passed previously to addsym(). If C<$name>
201existed in the set of symbols, returns its "trimmed" equivalent,
202otherwise returns C<undef>. This method must be called via an
203existing object.
204
205=item get_orig($trimmed)
206
207Returns the original name which was trimmed to C<$trimmed> by a
208previous call to addsym(), or C<undef> if C<$trimmed> does not
209correspond to a member of this set of symbols. This method must be
210called via an existing object.
211
212=item get_trimmed($name)
213
214Returns the trimmed name which was generated from C<$name> by a
215previous call to addsym(), or C<undef> if C<$name> is not a member
216of this set of symbols. This method must be called via an
217existing object.
218
219=item all_orig()
220
221Returns a list containing all of the original symbol names
222from this set.
223
224=item all_trimmed()
225
226Returns a list containing all of the trimmed symbol names
227from this set.
228
229=back
230
231=head1 AUTHOR
232
bd3fa61c 233Charles Bailey E<lt>I<bailey@newman.upenn.edu>E<gt>
ff0cee69
PP
234
235=head1 REVISION
236
237Last revised 14-Feb-1997, for Perl 5.004.
238