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