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