1 package ExtUtils::XSSymSet;
5 use vars qw( $VERSION );
10 my($pkg,$maxlen,$silent) = @_;
13 my($obj) = { '__M@xLen' => $maxlen, '__S!lent' => $silent };
19 my($self,$name,$maxlen,$silent) = @_;
21 unless (defined $maxlen) {
22 if (ref $self) { $maxlen ||= $self->{'__M@xLen'}; }
25 unless (defined $silent) {
26 if (ref $self) { $silent ||= $self->{'__S!lent'}; }
29 return $name if (length $name <= $maxlen);
32 # First, just try to remove duplicated delimiters
34 if (length $trimmed > $maxlen) {
35 # Next, all duplicated chars
36 $trimmed =~ s/(.)\1+/$1/g;
37 if (length $trimmed > $maxlen) {
38 my $squeezed = $trimmed;
39 my($xs,$prefix,$func) = $trimmed =~ /^(XS_)?(.*)_([^_]*)$/;
40 if (length $func <= 12) { # Try to preserve short function names
41 my $frac = int(length $prefix / (length $trimmed - $maxlen) + 0.5);
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 my $frac = int(length $trimmed / (length $trimmed - $maxlen) + 0.5);
55 if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; }
56 $squeezed = "$prefix$func";
57 $squeezed =~ s/$pat/$1/g;
58 if (length "$xs$squeezed" > $maxlen) {
60 $squeezed =~ s/$pat/$1/g;
62 $squeezed = "$xs$squeezed";
64 if (length $squeezed <= $maxlen) { $trimmed = $squeezed; }
66 my $frac = int((length $trimmed - $maxlen) / length $trimmed + 0.5);
67 my $pat = '(.).{$frac}';
68 $trimmed =~ s/$pat/$1/g;
72 carp "Warning: long symbol $name\n\ttrimmed to $trimmed\n\t" unless $silent;
78 my($self,$sym,$maxlen,$silent) = @_;
79 my $trimmed = $self->get_trimmed($sym);
81 return $trimmed if defined $trimmed;
83 $maxlen ||= $self->{'__M@xLen'} || 31;
84 $silent ||= $self->{'__S!lent'} || 0;
85 $trimmed = $self->trimsym($sym,$maxlen,1);
86 if (exists $self->{$trimmed}) {
88 $trimmed = $self->trimsym($sym,$maxlen-3,$silent);
89 while (exists $self->{"${trimmed}_$i"}) { $i++; }
90 carp "Warning: duplicate symbol $trimmed\n\tchanged to ${trimmed}_$i\n\t(original was $sym)\n\t"
94 elsif (not $silent and $trimmed ne $sym) {
95 carp "Warning: long symbol $sym\n\ttrimmed to $trimmed\n\t";
97 $self->{$trimmed} = $sym;
98 $self->{'__N+Map'}->{$sym} = $trimmed;
105 my $trimmed = $self->{'__N+Map'}->{$sym};
106 if (defined $trimmed) {
107 delete $self->{'__N+Map'}->{$sym};
108 delete $self->{$trimmed};
116 $self->{'__N+Map'}->{$sym};
121 my($self,$trimmed) = @_;
126 sub all_orig { (keys %{$_[0]->{'__N+Map'}}); }
127 sub all_trimmed { (grep { /^\w+$/ } keys %{$_[0]}); }
133 VMS::XSSymSet - keep sets of symbol names palatable to the VMS linker
139 $set = new VMS::XSSymSet;
140 while ($sym = make_symbol()) { $set->addsym($sym); }
141 foreach $safesym ($set->all_trimmed) {
142 print "Processing $safesym (derived from ",$self->get_orig($safesym),")\n";
146 $safesym = VMS::XSSymSet->trimsym($onesym);
150 Since the VMS linker distinguishes symbols based only on the first 31
151 characters of their names, it is occasionally necessary to shorten
152 symbol names in order to avoid collisions. (This is especially true of
153 names generated by xsubpp, since prefixes generated by nested package
154 names can become quite long.) C<VMS::XSSymSet> provides functions to
155 shorten names in a consistent fashion, and to track a set of names to
156 insure that each is unique. While designed with F<xsubpp> in mind, it
157 may be used with any set of strings.
159 This package supplies the following functions, all of which should be
164 =item new([$maxlen[,$silent]])
166 Creates an empty C<VMS::XSSymset> set of symbols. This function may be
167 called as a static method or via an existing object. If C<$maxlen> or
168 C<$silent> are specified, they are used as the defaults for maximum
169 name length and warning behavior in future calls to addsym() or
170 trimsym() via this object.
172 =item addsym($name[,$maxlen[,$silent]])
174 Creates a symbol name from C<$name>, using the methods described
175 under trimsym(), which is unique in this set of symbols, and returns
176 the new name. C<$name> and its resultant are added to the set, and
177 any future calls to addsym() specifying the same C<$name> will return
178 the same result, regardless of the value of C<$maxlen> specified.
179 Unless C<$silent> is true, warnings are output if C<$name> had to be
180 trimmed or changed in order to avoid collision with an existing symbol
181 name. C<$maxlen> and C<$silent> default to the values specified when
182 this set of symbols was created. This method must be called via an
185 =item trimsym($name[,$maxlen[,$silent]])
187 Creates a symbol name C<$maxlen> or fewer characters long from
188 C<$name> and returns it. If C<$name> is too long, it first tries to
189 shorten it by removing duplicate characters, then by periodically
190 removing non-underscore characters, and finally, if necessary, by
191 periodically removing characters of any type. C<$maxlen> defaults
192 to 31. Unless C<$silent> is true, a warning is output if C<$name>
193 is altered in any way. This function may be called either as a
194 static method or via an existing object, but in the latter case no
195 check is made to insure that the resulting name is unique in the
200 Removes C<$name> from the set of symbols, where C<$name> is the
201 original symbol name passed previously to addsym(). If C<$name>
202 existed in the set of symbols, returns its "trimmed" equivalent,
203 otherwise returns C<undef>. This method must be called via an
206 =item get_orig($trimmed)
208 Returns the original name which was trimmed to C<$trimmed> by a
209 previous call to addsym(), or C<undef> if C<$trimmed> does not
210 correspond to a member of this set of symbols. This method must be
211 called via an existing object.
213 =item get_trimmed($name)
215 Returns the trimmed name which was generated from C<$name> by a
216 previous call to addsym(), or C<undef> if C<$name> is not a member
217 of this set of symbols. This method must be called via an
222 Returns a list containing all of the original symbol names
227 Returns a list containing all of the trimmed symbol names
234 Charles Bailey E<lt>I<bailey@genetics.upenn.edu>E<gt>
238 Last revised 14-Feb-1997, for Perl 5.004.