Commit | Line | Data |
---|---|---|
ff0cee69 | 1 | package ExtUtils::XSSymSet; |
2 | ||
ff0cee69 | 3 | use strict; |
4 | use vars qw( $VERSION ); | |
b4ff380f | 5 | $VERSION = '1.1'; |
ff0cee69 | 6 | |
7 | ||
8 | sub 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 | ||
17 | sub 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_)?(.*)_([^_]*)$/; | |
b4ff380f CB |
39 | $xs ||= ''; |
40 | my $frac = 3; # replaces broken length-based calculations but w/same result | |
41 | my $pat = '([^_])'; | |
ff0cee69 | 42 | if (length $func <= 12) { # Try to preserve short function names |
ff0cee69 | 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 { | |
ff0cee69 | 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 | } | |
622db3b8 | 70 | warn "Warning: long symbol $name\n\ttrimmed to $trimmed\n\t" unless $silent; |
ff0cee69 | 71 | return $trimmed; |
72 | } | |
73 | ||
74 | ||
75 | sub 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++; } | |
622db3b8 | 88 | warn "Warning: duplicate symbol $trimmed\n\tchanged to ${trimmed}_$i\n\t(original was $sym)\n\t" |
ff0cee69 | 89 | unless $silent; |
90 | $trimmed .= "_$i"; | |
91 | } | |
92 | elsif (not $silent and $trimmed ne $sym) { | |
622db3b8 | 93 | warn "Warning: long symbol $sym\n\ttrimmed to $trimmed\n\t"; |
ff0cee69 | 94 | } |
95 | $self->{$trimmed} = $sym; | |
96 | $self->{'__N+Map'}->{$sym} = $trimmed; | |
97 | $trimmed; | |
98 | } | |
99 | ||
100 | ||
101 | sub 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 | ||
112 | sub get_trimmed { | |
113 | my($self,$sym) = @_; | |
114 | $self->{'__N+Map'}->{$sym}; | |
115 | } | |
116 | ||
117 | ||
118 | sub get_orig { | |
119 | my($self,$trimmed) = @_; | |
120 | $self->{$trimmed}; | |
121 | } | |
122 | ||
123 | ||
124 | sub all_orig { (keys %{$_[0]->{'__N+Map'}}); } | |
125 | sub all_trimmed { (grep { /^\w+$/ } keys %{$_[0]}); } | |
126 | ||
127 | __END__ | |
128 | ||
129 | =head1 NAME | |
130 | ||
131 | VMS::XSSymSet - keep sets of symbol names palatable to the VMS linker | |
132 | ||
133 | =head1 SYNOPSIS | |
134 | ||
135 | use VMS::XSSymSet; | |
136 | ||
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"; | |
141 | do_stuff($safesym); | |
142 | } | |
143 | ||
144 | $safesym = VMS::XSSymSet->trimsym($onesym); | |
145 | ||
146 | =head1 DESCRIPTION | |
147 | ||
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. | |
156 | ||
157 | This package supplies the following functions, all of which should be | |
158 | called as methods. | |
159 | ||
160 | =over 4 | |
161 | ||
162 | =item new([$maxlen[,$silent]]) | |
163 | ||
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. | |
169 | ||
170 | =item addsym($name[,$maxlen[,$silent]]) | |
171 | ||
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 | |
181 | existing object. | |
182 | ||
183 | =item trimsym($name[,$maxlen[,$silent]]) | |
184 | ||
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 | |
194 | set of symbols. | |
195 | ||
196 | =item delsym($name) | |
197 | ||
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 | |
202 | existing object. | |
203 | ||
204 | =item get_orig($trimmed) | |
205 | ||
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. | |
210 | ||
211 | =item get_trimmed($name) | |
212 | ||
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 | |
216 | existing object. | |
217 | ||
218 | =item all_orig() | |
219 | ||
220 | Returns a list containing all of the original symbol names | |
221 | from this set. | |
222 | ||
223 | =item all_trimmed() | |
224 | ||
225 | Returns a list containing all of the trimmed symbol names | |
226 | from this set. | |
227 | ||
228 | =back | |
229 | ||
230 | =head1 AUTHOR | |
231 | ||
bd3fa61c | 232 | Charles Bailey E<lt>I<bailey@newman.upenn.edu>E<gt> |
ff0cee69 | 233 | |
234 | =head1 REVISION | |
235 | ||
236 | Last revised 14-Feb-1997, for Perl 5.004. | |
237 |