vms/ext/XSSymSet.pm

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