package ExtUtils::XSSymSet; use strict; use Config; use vars qw( $VERSION ); $VERSION = '1.3'; sub new { my($pkg,$maxlen,$silent) = @_; $maxlen ||= 31; # Allow absurdly long symbols here if we've told the compiler to # do the shortening for us. $maxlen = 2048 if $Config{'useshortenedsymbols'}; $silent ||= 0; my($obj) = { '__M@xLen' => $maxlen, '__S!lent' => $silent }; bless $obj, $pkg; } sub trimsym { my($self,$name,$maxlen,$silent) = @_; unless (defined $maxlen) { if (ref $self) { $maxlen ||= $self->{'__M@xLen'}; } $maxlen ||= 31; } $maxlen = 2048 if $Config{'useshortenedsymbols'}; unless (defined $silent) { if (ref $self) { $silent ||= $self->{'__S!lent'}; } $silent ||= 0; } return $name if (length $name <= $maxlen); my $trimmed = $name; # First, just try to remove duplicated delimiters $trimmed =~ s/__/_/g; if (length $trimmed > $maxlen) { # Next, all duplicated chars $trimmed =~ s/(.)\1+/$1/g; if (length $trimmed > $maxlen) { my $squeezed = $trimmed; my($xs,$prefix,$func) = $trimmed =~ /^(XS_)?(.*)_([^_]*)$/; $xs ||= ''; my $frac = 3; # replaces broken length-based calculations but w/same result my $pat = '([^_])'; if (length $func <= 12) { # Try to preserve short function names if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; } $prefix =~ s/$pat/$1/g; $squeezed = "$xs$prefix" . "_$func"; if (length $squeezed > $maxlen) { $pat =~ s/A-Z//; $prefix =~ s/$pat/$1/g; $squeezed = "$xs$prefix" . "_$func"; } } else { if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; } $squeezed = "$prefix$func"; $squeezed =~ s/$pat/$1/g; if (length "$xs$squeezed" > $maxlen) { $pat =~ s/A-Z//; $squeezed =~ s/$pat/$1/g; } $squeezed = "$xs$squeezed"; } if (length $squeezed <= $maxlen) { $trimmed = $squeezed; } else { my $frac = int((length $trimmed - $maxlen) / length $trimmed + 0.5); my $pat = '(.).{$frac}'; $trimmed =~ s/$pat/$1/g; } } } warn "Warning: long symbol $name\n\ttrimmed to $trimmed\n\t" unless $silent; return $trimmed; } sub addsym { my($self,$sym,$maxlen,$silent) = @_; my $trimmed = $self->get_trimmed($sym); return $trimmed if defined $trimmed; $maxlen ||= $self->{'__M@xLen'} || 31; $silent ||= $self->{'__S!lent'} || 0; $trimmed = $self->trimsym($sym,$maxlen,1); if (exists $self->{$trimmed}) { my($i) = "00"; $trimmed = $self->trimsym($sym,$maxlen-3,$silent); while (exists $self->{"${trimmed}_$i"}) { $i++; } warn "Warning: duplicate symbol $trimmed\n\tchanged to ${trimmed}_$i\n\t(original was $sym)\n\t" unless $silent; $trimmed .= "_$i"; } elsif (not $silent and $trimmed ne $sym) { warn "Warning: long symbol $sym\n\ttrimmed to $trimmed\n\t"; } $self->{$trimmed} = $sym; $self->{'__N+Map'}->{$sym} = $trimmed; $trimmed; } sub delsym { my($self,$sym) = @_; my $trimmed = $self->{'__N+Map'}->{$sym}; if (defined $trimmed) { delete $self->{'__N+Map'}->{$sym}; delete $self->{$trimmed}; } $trimmed; } sub get_trimmed { my($self,$sym) = @_; $self->{'__N+Map'}->{$sym}; } sub get_orig { my($self,$trimmed) = @_; $self->{$trimmed}; } sub all_orig { (keys %{$_[0]->{'__N+Map'}}); } sub all_trimmed { (grep { /^\w+$/ } keys %{$_[0]}); } __END__ =head1 NAME ExtUtils::XSSymSet - keep sets of symbol names palatable to the VMS linker =head1 SYNOPSIS use ExtUtils::XSSymSet; $set = new ExtUtils::XSSymSet; while ($sym = make_symbol()) { $set->addsym($sym); } foreach $safesym ($set->all_trimmed) { print "Processing $safesym (derived from ", $self->get_orig($safesym), ")\n"; do_stuff($safesym); } $safesym = ExtUtils::XSSymSet->trimsym($onesym); =head1 DESCRIPTION Since the VMS linker distinguishes symbols based only on the first 31 characters of their names, it is occasionally necessary to shorten symbol names in order to avoid collisions. (This is especially true of names generated by xsubpp, since prefixes generated by nested package names can become quite long.) C provides functions to shorten names in a consistent fashion, and to track a set of names to insure that each is unique. While designed with F in mind, it may be used with any set of strings. This package supplies the following functions, all of which should be called as methods. =over 4 =item new([$maxlen[,$silent]]) Creates an empty C set of symbols. This function may be called as a static method or via an existing object. If C<$maxlen> or C<$silent> are specified, they are used as the defaults for maximum name length and warning behavior in future calls to addsym() or trimsym() via this object. If the compiler has been instructed to do its own symbol shortening via C<$Config{'useshortenedsymbols'}>, a value of 2048 is assumed for C<$maxlen> as a way of bypassing the shortening done by this module. =item addsym($name[,$maxlen[,$silent]]) Creates a symbol name from C<$name>, using the methods described under trimsym(), which is unique in this set of symbols, and returns the new name. C<$name> and its resultant are added to the set, and any future calls to addsym() specifying the same C<$name> will return the same result, regardless of the value of C<$maxlen> specified. Unless C<$silent> is true, warnings are output if C<$name> had to be trimmed or changed in order to avoid collision with an existing symbol name. C<$maxlen> and C<$silent> default to the values specified when this set of symbols was created. This method must be called via an existing object. =item trimsym($name[,$maxlen[,$silent]]) Creates a symbol name C<$maxlen> or fewer characters long from C<$name> and returns it. If C<$name> is too long, it first tries to shorten it by removing duplicate characters, then by periodically removing non-underscore characters, and finally, if necessary, by periodically removing characters of any type. C<$maxlen> defaults to 31. Unless C<$silent> is true, a warning is output if C<$name> is altered in any way. This function may be called either as a static method or via an existing object, but in the latter case no check is made to insure that the resulting name is unique in the set of symbols. If the compiler has been instructed to do its own symbol shortening via C<$Config{'useshortenedsymbols'}>, a value of 2048 is assumed for C<$maxlen> as a way of bypassing the shortening done by this module. =item delsym($name) Removes C<$name> from the set of symbols, where C<$name> is the original symbol name passed previously to addsym(). If C<$name> existed in the set of symbols, returns its "trimmed" equivalent, otherwise returns C. This method must be called via an existing object. =item get_orig($trimmed) Returns the original name which was trimmed to C<$trimmed> by a previous call to addsym(), or C if C<$trimmed> does not correspond to a member of this set of symbols. This method must be called via an existing object. =item get_trimmed($name) Returns the trimmed name which was generated from C<$name> by a previous call to addsym(), or C if C<$name> is not a member of this set of symbols. This method must be called via an existing object. =item all_orig() Returns a list containing all of the original symbol names from this set. =item all_trimmed() Returns a list containing all of the trimmed symbol names from this set. =back =head1 AUTHOR Charles Bailey EIE =head1 REVISION Last revised 8-Oct-2010, for Perl 5.13.6.