lib/ExtUtils/XSSymSet.pm

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