| 1 | package ExtUtils::XSSymSet; |
| 2 | |
| 3 | use strict; |
| 4 | use vars qw( $VERSION ); |
| 5 | $VERSION = '1.1'; |
| 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_)?(.*)_([^_]*)$/; |
| 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 | |
| 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++; } |
| 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 | |
| 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 | |
| 232 | Charles Bailey E<lt>I<bailey@newman.upenn.edu>E<gt> |
| 233 | |
| 234 | =head1 REVISION |
| 235 | |
| 236 | Last revised 14-Feb-1997, for Perl 5.004. |
| 237 | |