view release on metacpan or  search on metacpan

lib/Math/Base/Convert/Shortcuts.pm  view on Meta::CPAN

# 2) pad msb's
# 3) substr digit groups and get value

sub useFROMbaseShortcuts {
  my $bc = shift;
  my($ary,$hsh,$base,$str) = @{$bc}{qw(from fhsh fbase nstr)};
  my $bp = int(log($base)/log(2) +0.5);
  my $len 	= length($str);
  return ($bp,[0]) unless $len;		# no value in zero length string

  my $shrink	= 32 % ($bp * $base);		# bits short of 16 bits

# convert any strings in standard convertable bases that are NOT standard strings to the standard
  my $basnam = ref $ary;
  my $padchar = $ary->[0];
  if ($base == 16) {				# should be hex
    if ($basnam !~ /HEX$/i) {
      $bc->{fHEX} = $bc->HEX() unless exists $bc->{fHEX};
      my @h = @{$bc->{fHEX}};
      $str =~ s/(.)/$h[$hsh->{$1}]/g;		# translate string to HEX
      $padchar = 0;
    }
  }
  elsif ($base == 8) {
    if ($basnam !~ /OCT$/i) {
      $bc->{foct} = $bc->ocT() unless exists $bc->{foct};
      my @o = @{$bc->{foct}};
      $str =~ s/(.)/$o[$hsh->{$1}]/g;
      $padchar = '0';
    }
  }
  elsif ($base == 4) {				# will map to hex
    if ($basnam !~ /dna$/i) {
      $bc->{fDNA} = $bc->DNA() unless exists $bc->{fDNA};
      my @d = @{$bc->{fDNA}};
      $str =~ s/(.)/$d[$hsh->{$1}]/g;
      $padchar = 'A';
    }
  }
  elsif ($base == 2) {			# will map to binary
    if ($basnam !~ /bin$/) {
      $bc->{fbin} = $bc->bin() unless exists $bc->{fbin};
      my @b = @{$bc->{fbin}};
      $str =~ s/(.)/$b[$hsh->{$1}]/g;
      $padchar = '0';
    }
  }

# digits per 32 bit register - $dpr
# $dpr = int(32 / $bp)	  =	32 / digit bit width
#
# number of digits to pad string so the last digit fits exactly in a 32 bit register
# $pad = digits_per_reg - (string_length % $dpr)
  my $dpr	= int (32 / $bp);
  my $pad 	= $dpr - ($len % $dpr);
  $pad = 0 if $pad == $dpr;
  if ($pad) {
    $str = ($padchar x $pad) . $str;		# pad string with zero value digit
  }

# number of iterations % digits/register
  $len += $pad;
  my $i = 0;
  my @d32;
  while ($i < $len) {
    #
    # base16 digit = sub bx[base power](string fragment ) 
    # where base power is the width of each nibble and
    # base is the symbol value width in bits

    $useFROMbaseShortcuts[$bp]->(substr($str,$i,$dpr),\@d32,$hsh);
    $i += $dpr;
  }
  while($#d32 && ! $d32[$#d32]) {		# waste leading zeros
    pop @d32;
  }
  $bc->{b32str} = \@d32;
}

# map non-standard user base to bitstream lookup
#
sub usrmap {
  my($to,$map) = @_;
  my %map;
  while (my($key,$val) = each %$map) {
    $map{$key} = $to->[$val];
  }
  \%map;
}  

sub useTObaseShortcuts {
  my $bc = shift;
  my($base,$b32p,$to) = @{$bc}{qw( tbase b32str to )};
  my $bp = int(log($base)/log(2) +0.5);		# base power
  my $L = @$b32p;
  my $packed = pack("N$L", reverse @{$b32p});
  ref($to) =~ /([^:]+)$/;			# extract to base name
  my $bname = $1;
  my $str;
  if ($bp == 1) {				# binary
    $L *= 32;
    ($str = unpack("B$L",$packed)) =~ s/^0+//;	# suppress leading zeros
    $str =~ s/(.)/$to->[$1]/g if $bname eq 'user';
  }
  elsif ($bp == 4) {				# hex / base 16
    $L *= 8;
    ($str = unpack("H$L",$packed)) =~ s/^0+//;	# suppress leading zeros
    $str =~ s/(.)/$to->[CORE::hex($1)]/g if $bname eq 'user';
  }
   else {					# the rest
    my $map;
    if ($bname eq 'user') {			# special map request
      unless (exists $bc->{tmap}) {
        $bc->{tmap} = usrmap($to,$xlt->[$bp]);	# cache the map for speed
      }
      $map = $bc->{tmap};
    }
    elsif ($bp == 3) {				# octal variant?
      $map = $xlt->[$bp];
    } else {
      $map = $xlt->[0]->{$bname};		# standard map