This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Switch from Carp to plain old warn in vms/ext/XSSymSet.pm
[perl5.git] / 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