vms/ext/XSSymSet.pm

   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