vms/gen_shrfls.pl

   1 # Create global symbol declarations, transfer vector, and
   2 # linker options files for PerlShr.
   3 #
   4 # Processes the output of makedef.pl.
   5 #
   6 # Input:
   7 #    $cc_cmd - compiler command
   8 #    $objsuffix - file type (including '.') used for object files.
   9 #    $libperl - Perl object library.
  10 #    $extnames - package names for static extensions (used to generate
  11 #        linker options file entries for boot functions)
  12 #    $rtlopt - name of options file specifying RTLs to which PerlShr.Exe
  13 #        must be linked
  14 #
  15 # Output:
  16 #    PerlShr_Attr.Opt - linker options file which specifies that global vars
  17 #        be placed in NOSHR,WRT psects.  Use when linking any object files
  18 #        against PerlShr.Exe, since cc places global vars in SHR,WRT psects
  19 #        by default.
  20 #    PerlShr_Bld.Opt - declares universal symbols for PerlShr.Exe
  21 #    Perlshr_Gbl*.Mar, Perlshr_Gbl*.Obj (VAX  only) - declares global symbols
  22 #        for global vars (done here because gcc can't globaldef) and creates
  23 #        transfer vectors for routines on a VAX.
  24 #    PerlShr_Gbl.Opt (VAX only) - list of PerlShr_Gbl*.Obj, used for input
  25 #        to the linker when building PerlShr.Exe.
  26 #
  27 # To do:
  28 #   - figure out a good way to collect global vars in one psect, given that
  29 #     we can't use globaldef because of gcc.
  30 #   - then, check for existing files and preserve symbol and transfer vector
  31 #     order for upward compatibility
  32 #   - then, add GSMATCH to options file - but how do we insure that new
  33 #     library has everything old one did
  34 #     (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)?
  35 #
  36 # Author: Charles Bailey  bailey@newman.upenn.edu
  37
  38 use strict;
  39 require 5.000;
  40
  41 my $debug = $ENV{'GEN_SHRFLS_DEBUG'};
  42
  43 print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;
  44
  45 if ($ARGV[0] eq '-f') {
  46   open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
  47   print "Input taken from file $ARGV[1]\n" if $debug;
  48   @ARGV = ();
  49   while (<INP>) {
  50     chomp;
  51     push(@ARGV,split(/\|/,$_));
  52   }
  53   close INP;
  54   print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1;
  55 }
  56
  57 my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor
  58
  59 # Someday, we'll have $GetSyI built into perl . . .
  60 my $isvax = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .LE. 1024 .AND. F\$GetSyI(\"HW_MODEL\") .GT. 0\)`;
  61 chomp $isvax;
  62 print "\$isvax: \\$isvax\\\n" if $debug;
  63
  64 my $isi64 = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .GE. 4096)`;
  65 chomp $isi64;
  66 print "\$isi64: \\$isi64\\\n" if $debug;
  67
  68 print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
  69 my $docc = ($cc_cmd !~ /^~~/);
  70 print "\$docc = $docc\n" if $debug;
  71
  72 my ( $use_threads, $use_mymalloc, $care_about_case, $shorten_symbols,
  73      $debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir )
  74    = ( 0, 0, 0, 0, 0, 0, 0, 0 );
  75
  76 if (-f 'perl.h') { $dir = '[]'; }
  77 elsif (-f '[-]perl.h') { $dir = '[-]'; }
  78 else { die "$0: Can't find perl.h\n"; }
  79
  80 # Go see what is enabled in config.sh
  81 my $config = $dir . "config.sh";
  82 open CONFIG, '<', $config;
  83 while(<CONFIG>) {
  84     $use_threads++ if /usethreads='(define|yes|true|t|y|1)'/i;
  85     $use_mymalloc++ if /usemymalloc='(define|yes|true|t|y|1)'/i;
  86     $care_about_case++ if /d_vms_case_sensitive_symbols='(define|yes|true|t|y|1)'/i;
  87     $shorten_symbols++ if /d_vms_shorten_long_symbols='(define|yes|true|t|y|1)'/i;
  88     $debugging_enabled++ if /usedebugging_perl='(define|yes|true|t|y|1)'/i;
  89     $hide_mymalloc++ if /embedmymalloc='(define|yes|true|t|y|1)'/i;
  90     $isgcc++ if /gccversion='[^']/;
  91     $use_perlio++ if /useperlio='(define|yes|true|t|y|1)'/i;
  92 }
  93 close CONFIG;
  94
  95 # put quotes back onto defines - they were removed by DCL on the way in
  96 if (my ($prefix,$defines,$suffix) =
  97          ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) {
  98   $defines =~ s/^\((.*)\)$/$1/;
  99   $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/;
 100   my @defines = split(/,/,$defines);
 101   $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines))
 102               . ')' . $suffix;
 103 }
 104 print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
 105
 106 # check for gcc - if present, we'll need to use MACRO hack to
 107 # define global symbols for shared variables
 108
 109 print "\$isgcc: $isgcc\n" if $debug;
 110 print "\$debugging_enabled: $debugging_enabled\n" if $debug;
 111
 112 my $objsuffix = shift @ARGV;
 113 print "\$objsuffix: \\$objsuffix\\\n" if $debug;
 114 my $dbgprefix = shift @ARGV;
 115 print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
 116 my $olbsuffix = shift @ARGV;
 117 print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
 118 my $libperl = "${dbgprefix}libperl$olbsuffix";
 119 my $extnames = shift @ARGV;
 120 print "\$extnames: \\$extnames\\\n" if $debug;
 121 my $rtlopt = shift @ARGV;
 122 print "\$rtlopt: \\$rtlopt\\\n" if $debug;
 123
 124 my (%vars, %fcns);
 125
 126 open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";
 127
 128 while (my $line = <$makedefs>) {
 129   chomp $line;
 130   $line = shorten_symbol($line, $care_about_case) if $shorten_symbols;
 131   # makedef.pl loses distinction between vars and funcs, so
 132   # use the start of the name to guess and add specific
 133   # exceptions when we know about them.
 134   if ($line =~ m/^PL_/
 135       || $line eq 'PerlIO_perlio'
 136       || $line eq 'PerlIO_pending') {
 137     $vars{$line}++;
 138   }
 139   else {
 140     $fcns{$line}++;
 141   }
 142 }
 143
 144 if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
 145 foreach (split /\s+/, $extnames) {
 146   my($pkgname) = $_;
 147   $pkgname =~ s/::/__/g;
 148   $fcns{"boot_$pkgname"}++;
 149   print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
 150 }
 151
 152 # Eventually, we'll check against existing copies here, so we can add new
 153 # symbols to an existing options file in an upwardly-compatible manner.
 154
 155 my $marord = 1;
 156 open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
 157   or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
 158 if ($isvax) {
 159   open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
 160     or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
 161   print MAR "\t.title perlshr_gbl$marord\n";
 162 }
 163
 164 unless ($isgcc) {
 165   if ($isi64) {
 166     print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,NOEXE,RD,NOWRT,SHR\n";
 167     print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,NOEXE,RD,WRT,NOSHR\n";
 168   }
 169   else {
 170     print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n";
 171     print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n";
 172   }
 173   print OPTBLD "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
 174 }
 175 print OPTBLD "case_sensitive=yes\n" if $care_about_case;
 176 my $count = 0;
 177 foreach my $var (sort (keys %vars)) {
 178   if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
 179   else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
 180   # This hack brought to you by the lack of a globaldef in gcc.
 181   if ($isgcc) {
 182     if ($count++ > 200) {  # max 254 psects/file
 183       print MAR "\t.end\n";
 184       close MAR;
 185       $marord++;
 186       open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
 187         or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
 188       print MAR "\t.title perlshr_gbl$marord\n";
 189       $count = 0;
 190     }
 191     print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n";
 192     print MAR "\t${var}::       .blkl 1\n";
 193   }
 194 }
 195
 196 print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax);
 197 foreach my $func (sort keys %fcns) {
 198   if ($isvax) {
 199     print MAR "\t.transfer $func\n";
 200     print MAR "\t.mask $func\n";
 201     print MAR "\tjmp G\^${func}+2\n";
 202   }
 203   else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
 204 }
 205 if ($isvax) {
 206   print MAR "\t.end\n";
 207   close MAR;
 208 }
 209
 210 open(OPTATTR, '>', "${dir}perlshr_attr.opt")
 211   or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
 212 if ($isgcc) {
 213 # TODO -- lost ability to distinguish constant vars from others when
 214 # we switched to using makedef.pl for input.
 215 #  foreach my $var (sort keys %cvars) {
 216 #    print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
 217 #  }
 218   foreach my $var (sort keys %vars) {
 219     print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
 220   }
 221 }
 222 else {
 223   print OPTATTR "! No additional linker directives are needed when using DECC\n";
 224 }
 225 close OPTATTR;
 226
 227 my $incstr = 'PERL,GLOBALS';
 228 my (@symfiles, $drvrname);
 229 if ($isvax) {
 230   $drvrname = "Compile_shrmars.tmp_".time;
 231   open (DRVR,'>', $drvrname) or die "$0: Can't write to $drvrname: $!\n";
 232   print DRVR "\$ Set NoOn\n";
 233   print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n";
 234   print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n";
 235   print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n";
 236   print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n";
 237   print DRVR "\$ Set Verify\n";
 238   print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
 239   do {
 240     push(@symfiles,"perlshr_gbl$marord");
 241     print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n";
 242     print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n";
 243   } while (--$marord);
 244   # We had to have a working miniperl to run this program; it's probably the
 245   # one we just built.  It depended on LibPerl, which will be changed when
 246   # the PerlShr_Gbl* modules get inserted, so miniperl will be out of date,
 247   # and so, therefore, will all of its dependents . . .
 248   # We touch LibPerl here so it'll be back 'in date', and we won't rebuild
 249   # miniperl etc., and therefore LibPerl, the next time we invoke MM[KS].
 250   print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n";
 251   print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n";
 252   close DRVR;
 253 }
 254
 255 # Initial hack to permit building of compatible shareable images for a
 256 # given version of Perl.
 257 if ($ENV{PERLSHR_USE_GSMATCH}) {
 258   if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
 259     # Build up a major ID. Since it can only be 8 bits, we encode the version
 260     # number in the top four bits and use the bottom four for build options
 261     # that'll cause incompatibilities
 262     my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/;
 263     $ver += 0; $sub += 0;
 264     my $gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for
 265                                                   # dev, but be more forgiving
 266                                                   # for releases
 267
 268     $ver *=16;
 269     $ver += 8 if $debugging_enabled;    # If DEBUGGING is set
 270     $ver += 4 if $use_threads;          # if we're threaded
 271     $ver += 2 if $use_mymalloc;         # if we're using perl's malloc
 272     print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
 273   }
 274   else {
 275     my $major = int($] * 1000)                        & 0xFF;  # range 0..255
 276     my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF;  # range 0..255
 277     print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
 278   }
 279   print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,',
 280                map(",$_$objsuffix",@symfiles), "\n";
 281 }
 282 elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
 283 # Include object modules and RTLs in options file
 284 # Linker wants /Include and /Library on different lines
 285 print OPTBLD "$libperl/Include=($incstr)\n";
 286 print OPTBLD "$libperl/Library\n";
 287 open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
 288 while (<RTLOPT>) { print OPTBLD; }
 289 close RTLOPT;
 290 close OPTBLD;
 291
 292 exec "\$ \@$drvrname" if $isvax;
 293
 294
 295 # Symbol shortening Copyright (c) 2012 Craig A. Berry
 296 #
 297 # Released under the same terms as Perl itself.
 298 #
 299 # This code provides shortening of long symbols (> 31 characters) using the
 300 # same mechanism as the OpenVMS C compiler.  The basic procedure is to compute
 301 # an AUTODIN II checksum of the entire symbol, encode the checksum in base32,
 302 # and glue together a shortened symbol from the first 23 characters of the
 303 # original symbol plus the encoded checksum appended.  The output format is
 304 # the same used in the name mangler database, stored by default in
 305 # [.CXX_REPOSITORY]CXX$DEMANGLER_DB.
 306
 307 sub crc32 {
 308     use constant autodin_ii_table => [
 309         0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f,
 310         0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988,
 311         0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2,
 312         0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7,
 313         0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
 314         0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172,
 315         0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c,
 316         0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59,
 317         0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423,
 318         0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
 319         0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106,
 320         0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433,
 321         0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d,
 322         0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e,
 323         0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
 324         0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65,
 325         0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7,
 326         0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0,
 327         0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa,
 328         0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
 329         0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81,
 330         0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a,
 331         0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84,
 332         0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1,
 333         0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
 334         0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc,
 335         0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e,
 336         0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b,
 337         0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55,
 338         0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
 339         0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28,
 340         0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d,
 341         0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f,
 342         0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38,
 343         0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
 344         0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777,
 345         0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69,
 346         0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2,
 347         0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc,
 348         0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
 349         0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693,
 350         0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94,
 351         0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d,
 352     ];
 353
 354     my $input_string = shift;
 355     my $crc = 0xFFFFFFFF;
 356
 357     for my $byte (unpack 'C*', $input_string) {
 358         $crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
 359     }
 360     return ~$crc;
 361 }
 362
 363 sub base32 {
 364     my $input = shift;
 365     my $output = '';
 366     use constant base32hex_table => [
 367         '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
 368         'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
 369         'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
 370         'u', 'v'
 371     ];
 372
 373     # Grab lowest 5 bits and look up conversion in table.  Lather, rinse,
 374     # repeat for a total of 7, 5-bit chunks to accommodate 32 bits of input.
 375
 376     for (0..6) {
 377         $output  = base32hex_table->[$input & 0x1f] . $output;
 378         $input >>= 5;     # position to look at next 5
 379     }
 380     $output .= '$';       #  It's DEC, so use '$' not '=' to pad.
 381
 382     return $output;
 383 }
 384
 385 sub shorten_symbol {
 386     my $input_symbol = shift;
 387     my $as_is_flag = shift;
 388     my $symbol = $input_symbol;
 389
 390     return $symbol unless length($input_symbol) > 31;
 391
 392     $symbol = uc($symbol) unless $as_is_flag;
 393     my $crc = crc32($symbol);
 394     $crc = ~$crc;  # Compiler uses non-inverted form.
 395     my $b32 = base32($crc);
 396     $b32 = uc($b32) unless $as_is_flag;
 397
 398     return substr($symbol, 0, 23) . $b32;
 399 }
 400
 401 __END__
 402