1 package ExtUtils::XSSymSet;
4 use vars qw( $VERSION );
9 my($pkg,$maxlen,$silent) = @_;
12 my($obj) = { '__M@xLen' => $maxlen, '__S!lent' => $silent };
18 my($self,$name,$maxlen,$silent) = @_;
20 unless (defined $maxlen) {
21 if (ref $self) { $maxlen ||= $self->{'__M@xLen'}; }
24 unless (defined $silent) {
25 if (ref $self) { $silent ||= $self->{'__S!lent'}; }
28 return $name if (length $name <= $maxlen);
31 # First, just try to remove duplicated delimiters
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_)?(.*)_([^_]*)$/;
40 my $frac = 3; # replaces broken length-based calculations but w/same result
42 if (length $func <= 12) { # Try to preserve short function names
43 if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; }
44 $prefix =~ s/$pat/$1/g;
45 $squeezed = "$xs$prefix" . "_$func";
46 if (length $squeezed > $maxlen) {
48 $prefix =~ s/$pat/$1/g;
49 $squeezed = "$xs$prefix" . "_$func";
53 if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; }
54 $squeezed = "$prefix$func";
55 $squeezed =~ s/$pat/$1/g;
56 if (length "$xs$squeezed" > $maxlen) {
58 $squeezed =~ s/$pat/$1/g;
60 $squeezed = "$xs$squeezed";
62 if (length $squeezed <= $maxlen) { $trimmed = $squeezed; }
64 my $frac = int((length $trimmed - $maxlen) / length $trimmed + 0.5);
65 my $pat = '(.).{$frac}';
66 $trimmed =~ s/$pat/$1/g;
70 warn "Warning: long symbol $name\n\ttrimmed to $trimmed\n\t" unless $silent;
76 my($self,$sym,$maxlen,$silent) = @_;
77 my $trimmed = $self->get_trimmed($sym);
79 return $trimmed if defined $trimmed;
81 $maxlen ||= $self->{'__M@xLen'} || 31;
82 $silent ||= $self->{'__S!lent'} || 0;
83 $trimmed = $self->trimsym($sym,$maxlen,1);
84 if (exists $self->{$trimmed}) {
86 $trimmed = $self->trimsym($sym,$maxlen-3,$silent);
87 while (exists $self->{"${trimmed}_$i"}) { $i++; }
88 warn "Warning: duplicate symbol $trimmed\n\tchanged to ${trimmed}_$i\n\t(original was $sym)\n\t"
92 elsif (not $silent and $trimmed ne $sym) {
93 warn "Warning: long symbol $sym\n\ttrimmed to $trimmed\n\t";
95 $self->{$trimmed} = $sym;
96 $self->{'__N+Map'}->{$sym} = $trimmed;
103 my $trimmed = $self->{'__N+Map'}->{$sym};
104 if (defined $trimmed) {
105 delete $self->{'__N+Map'}->{$sym};
106 delete $self->{$trimmed};
114 $self->{'__N+Map'}->{$sym};
119 my($self,$trimmed) = @_;
124 sub all_orig { (keys %{$_[0]->{'__N+Map'}}); }
125 sub all_trimmed { (grep { /^\w+$/ } keys %{$_[0]}); }
131 VMS::XSSymSet - keep sets of symbol names palatable to the VMS linker
137 $set = new VMS::XSSymSet;
138 while ($sym = make_symbol()) { $set->addsym($sym); }
139 foreach $safesym ($set->all_trimmed) {
140 print "Processing $safesym (derived from ",$self->get_orig($safesym),")\n";
144 $safesym = VMS::XSSymSet->trimsym($onesym);
148 Since the VMS linker distinguishes symbols based only on the first 31
149 characters of their names, it is occasionally necessary to shorten
150 symbol names in order to avoid collisions. (This is especially true of
151 names generated by xsubpp, since prefixes generated by nested package
152 names can become quite long.) C<VMS::XSSymSet> provides functions to
153 shorten names in a consistent fashion, and to track a set of names to
154 insure that each is unique. While designed with F<xsubpp> in mind, it
155 may be used with any set of strings.
157 This package supplies the following functions, all of which should be
162 =item new([$maxlen[,$silent]])
164 Creates an empty C<VMS::XSSymset> set of symbols. This function may be
165 called as a static method or via an existing object. If C<$maxlen> or
166 C<$silent> are specified, they are used as the defaults for maximum
167 name length and warning behavior in future calls to addsym() or
168 trimsym() via this object.
170 =item addsym($name[,$maxlen[,$silent]])
172 Creates a symbol name from C<$name>, using the methods described
173 under trimsym(), which is unique in this set of symbols, and returns
174 the new name. C<$name> and its resultant are added to the set, and
175 any future calls to addsym() specifying the same C<$name> will return
176 the same result, regardless of the value of C<$maxlen> specified.
177 Unless C<$silent> is true, warnings are output if C<$name> had to be
178 trimmed or changed in order to avoid collision with an existing symbol
179 name. C<$maxlen> and C<$silent> default to the values specified when
180 this set of symbols was created. This method must be called via an
183 =item trimsym($name[,$maxlen[,$silent]])
185 Creates a symbol name C<$maxlen> or fewer characters long from
186 C<$name> and returns it. If C<$name> is too long, it first tries to
187 shorten it by removing duplicate characters, then by periodically
188 removing non-underscore characters, and finally, if necessary, by
189 periodically removing characters of any type. C<$maxlen> defaults
190 to 31. Unless C<$silent> is true, a warning is output if C<$name>
191 is altered in any way. This function may be called either as a
192 static method or via an existing object, but in the latter case no
193 check is made to insure that the resulting name is unique in the
198 Removes C<$name> from the set of symbols, where C<$name> is the
199 original symbol name passed previously to addsym(). If C<$name>
200 existed in the set of symbols, returns its "trimmed" equivalent,
201 otherwise returns C<undef>. This method must be called via an
204 =item get_orig($trimmed)
206 Returns the original name which was trimmed to C<$trimmed> by a
207 previous call to addsym(), or C<undef> if C<$trimmed> does not
208 correspond to a member of this set of symbols. This method must be
209 called via an existing object.
211 =item get_trimmed($name)
213 Returns the trimmed name which was generated from C<$name> by a
214 previous call to addsym(), or C<undef> if C<$name> is not a member
215 of this set of symbols. This method must be called via an
220 Returns a list containing all of the original symbol names
225 Returns a list containing all of the trimmed symbol names
232 Charles Bailey E<lt>I<bailey@newman.upenn.edu>E<gt>
236 Last revised 14-Feb-1997, for Perl 5.004.