vms/ext/XSSymSet.pm

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