This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
679ede4bcf7899d6fc0e6919653bf38642ce64e0
[perl5.git] / 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