Commit | Line | Data |
ff0cee69 |
1 | package ExtUtils::XSSymSet; |
2 | |
3 | use Carp qw( &carp ); |
4 | use strict; |
5 | use vars qw( $VERSION ); |
6 | $VERSION = '1.0'; |
7 | |
8 | |
9 | sub 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 | |
18 | sub 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 | |
77 | sub 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 | |
103 | sub 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 | |
114 | sub get_trimmed { |
115 | my($self,$sym) = @_; |
116 | $self->{'__N+Map'}->{$sym}; |
117 | } |
118 | |
119 | |
120 | sub get_orig { |
121 | my($self,$trimmed) = @_; |
122 | $self->{$trimmed}; |
123 | } |
124 | |
125 | |
126 | sub all_orig { (keys %{$_[0]->{'__N+Map'}}); } |
127 | sub all_trimmed { (grep { /^\w+$/ } keys %{$_[0]}); } |
128 | |
129 | __END__ |
130 | |
131 | =head1 NAME |
132 | |
133 | VMS::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 | |
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. |
158 | |
159 | This package supplies the following functions, all of which should be |
160 | called as methods. |
161 | |
162 | =over 4 |
163 | |
164 | =item new([$maxlen[,$silent]]) |
165 | |
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. |
171 | |
172 | =item addsym($name[,$maxlen[,$silent]]) |
173 | |
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 |
183 | existing object. |
184 | |
185 | =item trimsym($name[,$maxlen[,$silent]]) |
186 | |
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 |
196 | set of symbols. |
197 | |
198 | =item delsym($name) |
199 | |
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 |
204 | existing object. |
205 | |
206 | =item get_orig($trimmed) |
207 | |
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. |
212 | |
213 | =item get_trimmed($name) |
214 | |
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 |
218 | existing object. |
219 | |
220 | =item all_orig() |
221 | |
222 | Returns a list containing all of the original symbol names |
223 | from this set. |
224 | |
225 | =item all_trimmed() |
226 | |
227 | Returns a list containing all of the trimmed symbol names |
228 | from this set. |
229 | |
230 | =back |
231 | |
232 | =head1 AUTHOR |
233 | |
234 | Charles Bailey E<lt>I<bailey@genetics.upenn.edu>E<gt> |
235 | |
236 | =head1 REVISION |
237 | |
238 | Last revised 14-Feb-1997, for Perl 5.004. |
239 | |