KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

652
database/perl/vendor/lib/Math/Base/Convert.pm vendored Normal file
View File

@@ -0,0 +1,652 @@
#!/usr/bin/perl
package Math::Base::Convert;
#use diagnostics;
use Carp;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS @BASES $signedBase);
# @Bases, $signedBase imported from Math::Base::Convert::Bases
require Exporter;
require Math::Base::Convert::Shortcuts;
require Math::Base::Convert::CalcPP;
require Math::Base::Convert::Bases; # drag in BASES
@ISA = qw(
Math::Base::Convert::Shortcuts
Math::Base::Convert::CalcPP
Exporter
);
$VERSION = do { my @r = (q$Revision: 0.11 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
@EXPORT_OK = ( qw( cnv cnvpre cnvabs basemap ), @BASES );
%EXPORT_TAGS = (
all => [@EXPORT_OK],
base => [ 'basemap', @BASES ]
);
my $functions = join '', keys %{__PACKAGE__ .'::'}; # before 'strict'
use strict;
my $package = __PACKAGE__;
my $packageLen = length __PACKAGE__;
my $bs = $package .'::_bs::'; # indentify 'base sub'
my %num2sub = (
2 => &bin,
4 => &DNA,
8 => &ocT,
10 => &dec,
16 => &HEX,
64 => &m64
);
# return a hash map of the base array, including upper/lower case variants
#
sub basemap {
shift if ref $_[0] eq $package; # waste if method call
my $base = validbase($_[0]); # return array pointer
ref($base) =~ /$bs(.+)/; # sub name is $1
if ($1 eq 'user') { # if user array
my $aryhsh = {};
@{$aryhsh}{@$base} = (0..$#$base);
return $aryhsh;
}
my @all = $functions =~ /$1/gi; # get all matching sub names regardless of case
# names are strings
no strict;
my %aryhsh;
foreach (@all) {
$_ = $package->can($_); # return sub ref
$_ = &$_; # array pointer
foreach my $i (0..$#$_) {
$aryhsh{$_->[$i]} = $i; # map keys to index
}
}
return \%aryhsh;
}
# check for internal base
sub validbase {
my $base = shift;
my $ref;
if (($ref = ref $base)) {
if ($ref eq 'ARRAY') { # user supplied
my @base = @{$base};
my $len = @base;
Carp::croak "base to short, < 2" unless $len > 1;
Carp::croak "base to long, > 65535" unless $len < 65536;
$base = bless \@base, $bs .'user';
return bless $base, $bs . 'user';
}
elsif ($ref =~ /^$bs/) { # internal base
return $base;
}
else {
$base = 'reference';
}
}
elsif ($base =~ /\D/) { # is a string
my $rv = $package->can($base);
return &$rv if $rv;
} else {
return $num2sub{$base} if exists $num2sub{$base};
}
Carp::croak "not a valid base: $base";
}
sub vet {
my $class = shift;
my $from = shift || '';
my $to = shift || '';
$to =~ s/\s+//g if $to && ! ref $to; # strip white space
$from =~ s/\s+//g if $from && ! ref $from;
unless ($from) { # defaults if not defined
$to = &HEX;
$from = &dec;
}
else {
$from = validbase($from);
unless ($to) {
$to = &HEX;
} else {
$to = validbase($to);
}
}
# convert sub ref's to variables
# $to = &$to;
# ($from, my $fhsh) = &$from;
my $prefix = ref $to;
if ($prefix =~ /HEX$/i) {
$prefix = '0x';
}
elsif ($prefix =~ /OCT$/i) {
$prefix = '0';
}
elsif ($prefix =~ /bin$/) {
$prefix = '0b';
} else {
$prefix = '';
}
bless {
to => $to,
tbase => scalar @$to,
from => $from,
fhsh => basemap($from),
fbase => scalar @$from,
prefix => $prefix
}, $class;
}
sub new {
my $proto = shift;
my $class = ref $proto || $proto || $package;
vet($class,@_);
}
sub _cnv {
my $bc = shift;
my $nstr;
if (ref $bc && ref($bc) eq $package) { # method call?
$nstr = shift; # yes, number to convert is next arg
} else {
$nstr = $bc; # no, first arg is number to convert
$bc = $package->new(@_);
}
return $nstr unless keys %$bc; # if there really is no conversion
$nstr = '' unless defined $nstr;
my($from,$fbase,$fhsh) = @{$bc}{qw( from fbase fhsh )};
my $ref = ref $from;
if ($ref eq 'user' || $fbase > $signedBase) { # known, signed character sets?
$bc->{sign} = ''; # no
} else { # yes
$nstr =~ s/^([+-])//; # strip sign
$bc->{sign} = $1 && $1 eq '-' ? '-' : ''; # and save for possible restoration
if ($ref =~ /(HEX)$/i) {
$nstr =~ s/^0x//i; # snip prefix, including typo's
}
elsif ($ref =~ /bin/i) {
$nstr =~ s/^0b//i; # snip prefix, including typo's
}
$nstr =~ s/^[$from->[0]]+//; # snip leading zeros
}
my $fclass = join '', keys %$fhsh;
if ($nstr =~ /[^\Q$fclass\E]/) { # quote metacharacters
$ref =~ /([^:]+)$/;
Carp::croak "input character not in '$1'\nstring:\t$nstr\nbase:\t$fclass\n";
}
$bc->{nstr} = $nstr;
$bc;
}
#
# Our internal multiply & divide = base 32
# Maximum digit length for a binary base = 32*ln(2)/ln(base)
# 0bnnnnnnnnnnn
# 0nnnnnnnnnnnn
# 0xnnnnnnnnnnn
#
my %maxdlen = (# digits, key is base
2 => 31, # 2^1
4 => 16, # 2^2
8 => 10, # 2^3
16 => 8, # 2^4
32 => 6, # 2^5
64 => 5, # 2^6
128 => 4, # 2^7
256 => 4 # 2^8
);
sub cnv {
my @rv = &cnvpre;
return @rv if wantarray;
return ($rv[0] . $rv[2]); # sign and string only
}
sub cnvabs {
my @rv = &cnvpre;
return @rv if wantarray;
return $rv[2] # string only
}
sub cnvpre {
my $bc = &_cnv;
return $bc unless ref $bc;
my($from,$fbase,$to,$tbase,$sign,$prefix,$nstr) = @{$bc}{qw( from fbase to tbase sign prefix nstr)};
my $slen = length($nstr);
my $tref = ref($to);
unless ($slen) { # zero length input
$nstr = $to->[0]; # return zero
}
elsif (lc $tref eq lc ref($from)) {# no base conversion
if ($tref ne ref($from)) { # convert case?
if ($tref =~ /(?:DNA|HEX)/) {
$nstr = uc $nstr; # force upper case
} else {
$nstr = lc $nstr; # or force lower case
}
}
}
else { # convert
my $fblen = length($fbase);
if ($fbase & $fbase -1 || # from base is not power of 2
$fblen > 256 ) { # no shortcuts,...
$bc->useFROMbaseto32wide;
}
# if a large base and digit string will fit in a single 32 bit register
elsif ( $fblen > 32 && # big base
# exists $maxdlen{$fbase} && # has to exist
! $slen > $maxdlen{$fbase}) {
$bc->useFROMbaseto32wide; # CalcPP is faster
}
else { # shortcuts faster for big numbers
$bc->useFROMbaseShortcuts;
}
################################
# input converted to base 2^32 #
################################
if ($tbase & $tbase -1 || # from base is not power of 2
$tbase > 256 ) { # no shortcuts,...
$nstr = $bc->use32wideTObase;
}
# if big base and digit string fits in a single 32 bit register
elsif ( $tbase > 32 && @{$bc->{b32str}} == 1) {
$nstr = $bc->use32wideTObase; # CalcPP is faster
}
else {
$nstr = $bc->useTObaseShortcuts; # shortcuts faster for big numbers
}
} # end convert
$nstr = $to->[0] unless length($nstr);
return ($sign,$prefix,$nstr) if wantarray;
if (#$prefix ne '' && # 0, 0x, 0b
$tbase <= $signedBase && # base in signed set
$tref ne 'user' ) { # base standard
return ($sign . $prefix . $nstr);
}
return ($prefix . $nstr);
}
sub _cnvtst {
my $bc = &_cnv;
return $bc unless ref $bc;
$bc->useFROMbaseto32wide;
return $bc->use32wideTObase unless wantarray;
return (@{$bc}{qw( sign prefix )},$bc->use32wideTObase);
}
=head1 NAME
Math::Base::Convert - very fast base to base conversion
=head1 SYNOPSIS
=head2 As a function
use Math::Base::Convert qw( :all )
use Math::Base::Convert qw(
cnv
cnvabs
cnvpre
basemap
# comments
bin base 2 0,1
dna base 4 lower case dna
DNA base 4 upper case DNA
oct base 8 octal
dec base 10 decimal
hex base 16 lower case hex
HEX base 16 upper case HEX
b62 base 62
b64 base 64 month:C:12 day:V:31
m64 base 64 0-63 from MIME::Base64
iru base 64 P10 protocol - IRCu daemon
url base 64 url with no %2B %2F expansion of + - /
rex base 64 regular expression variant
id0 base 64 IDentifier style 0
id1 base 64 IDentifier style 1
xnt base 64 XML Name Tokens (Nmtoken)
xid base 64 XML identifiers (Name)
b85 base 85 RFC 1924 for IPv6 addresses
ascii base 96 7 bit printible 0x20 - 0x7F
);
my $converted = cnv($number,optionalFROM,optionalTO);
my $basemap = basmap(base);
=head2 As a method:
use Math::Base::Convert;
use Math::Base::Convert qw(:base);
my $bc = new Math::Base::Convert(optionalFROM,optionalTO);
my $converted = $bc->cnv($number);
my $basemap = $bc->basemap(base);
=head1 DESCRIPTION
This module provides fast functions and methods to convert between arbitrary number bases
from 2 (binary) thru 65535.
This module is pure Perl, has no external dependencies, and is backward compatible
with old versions of Perl 5.
=head1 PREFERRED USE
Setting up the conversion parameters, context and error checking consume a significant portion of the execution time of a
B<single> base conversion. These operations are performed each time B<cnv> is called as a function.
Using method calls eliminates a large portion of this overhead and will improve performance for
repetitive conversions. See the benchmarks sub-directory in this distribution.
=head1 BUILT IN NUMBER SETS
Number set variants courtesy of the authors of Math::Base:Cnv and
Math::BaseConvert.
The functions below return a reference to an array
$arrayref = function;
bin => ['0', '1'] # binary
dna => ['a','t','c','g'] # lc dna
DNA => ['A','T','C','G'], {default} # uc DNA
oct => ['0'..'7'] # octal
dec => ['0'..'9'] # decimal
hex => ['0'..'9', 'a'..'f'] # lc hex
HEX => ['0'..'9', 'A'..'F'] {default} # uc HEX
b62 => ['0'..'9', 'a'..'z', 'A'..'Z'] # base 62
b64 => ['0'..'9', 'A'..'Z', 'a'..'z', '.', '_'] # m:C:12 d:V:31
m64 => ['A'..'Z', 'a'..'z', '0'..'9', '+', '/'] # MIMI::Base64
iru => ['A'..'Z', 'a'..'z', '0'..'9', '[', ']'] # P10 - IRCu
url => ['A'..'Z', 'a'..'z', '0'..'9', '*', '-'] # url no %2B %2F
rex => ['A'..'Z', 'a'..'z', '0'..'9', '!', '-'] # regex variant
id0 => ['A'..'Z', 'a'..'z', '0'..'9', '_', '-'] # ID 0
id1 => ['A'..'Z', 'a'..'z', '0'..'9', '.', '_'] # ID 1
xnt => ['A'..'Z', 'a'..'z', '0'..'9', '.', '-'] # XML (Nmtoken)
xid => ['A'..'Z', 'a'..'z', '0'..'9', '_', ':'] # XML (Name)
b85 => ['0'..'9', 'A'..'Z', 'a'..'z', '!', '#', # RFC 1924
'$', '%', '&', '(', ')', '*', '+', '-',
';', '<', '=', '>', '?', '@', '^', '_',
'', '{', '|', '}', '~']
An arbitrary base 96 composed of printable 7 bit ascii
from 0x20 (space) through 0x7F (tilde ~)
ascii => [
' ','!','"','#','$','%','&',"'",'(',')',
'*','+',',','-','.','/',
'0','1','2','3','4','5','6','7','8','9',
':',';','<','=','>','?','@',
'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
'[','\',']','^','_','`',
'a','b','c','d','e','f','g','h','i','j','k','l','m',
'n','o','p','q','r','s','t','u','v','w','x','y','z',
'{','|','}','~']
NOTE: Clean text with =~ s/\s+/ /; before applying to ascii
=head1 USAGE
=over 4
=item * $converted = cnv($number,[from],[to])
SCALAR context: array context covered later in this document.
To preserve similarity to other similar base conversion modules, B<cnv>
returns the converted number string with SIGN if both the input and output
base strings are in known signed set of bases in this module.
In the case of binary, octal, hex, all leading base designator strings such as
'0b','0', '0x' are automatically stripped from the input. Base designator
strings are NOT applied to the output.
The context of base FROM and TO is optional and flexible.
Unconditional conversion from decimal to HEX [upper case]
$converted = cnv($number);
Example conversion from octal to default HEX [upper case] with different
context for the 'octal' designator.
base as a number
$converted = cnv($number,8);
base as a function (imported)
$converted = cnv($number,oct);
base as text
$converted = convbase($number,'oct');
Conversion to/from arbitrary bases i.e.
$converted = cnv($number); # dec -> hex (default)
$converted = cnv($number,oct); # oct to HEX
$converted = cnv($number,10,HEX); # dec to uc HEX
$converted = cnv($number,10,hex); # dec to lc hex
$converted = cnv($number,dec,hex);# same
pointer notation
$converted = cnv($number, oct => dec);
$converted = cnv($number,10 => 23); # dec to base23
$converted = cnv($number,23 => 5); # b23 to base5
etc...
=item * $bc = new Math::Base::Convert([from],[to]);
This method has the same usage and syntax for FROM and TO as B<cnv> above.
Setup for unconditional conversion from HEX to decimal
$bc = new Math::Base::Convert();
Example conversion from octal to decimal
base number
$bc = new Math::Base::Convert(8);
base function (imported)
$bc = new Math::Base::Convert(oct);
base text
$bc = new Math::Base::Convert('oct')
The number conversion for any of the above:
NOTE: iterative conversions using a method pointer are ALWAYS faster than
calling B<cnv> as a function.
$converted = $bc->cnv($number);
=item * $converted = cnvpre($number,[from],[to])
Same as B<cnv> except that base descriptor PREfixes are applied to B<binary>,
B<octal>, and B<hexadecimal> output strings.
=item * $converted = cnvabs($number,[from],[to])
Same as B<cnv> except that the ABSolute value of the number string is
returned without SIGN is returned. i.e. just the raw string.
=item * ($sign,$prefix,$string) = cnv($number,[$from,[$to]])
=item * ($sign,$prefix,$string) = cnv($number,[$from,[$to]])
=item * ($sign,$prefix,$string) = cnv($number,[$from,[$to]])
ARRAY context:
All three functions return the same items in array context.
sign the sign of the input number string
prefix the prefix which would be applied to output
string the raw output string
=item * $basemap = basemap(base);
=item * $basemap = $bc->basemap(base);
This function / method returns a pointer to a hash that maps the keys of a base to its
numeric value for base conversion. It accepts B<base> in any of the forms
described for B<cnv>.
The return basemap includes upper and lower case variants of the the number
base in cases such as B<hex> where upper and lower case a..f, A..F map to
the same numeric value for base conversion.
i.e. $hex_ptr = {
0 => 0,
1 => 1,
2 => 2,
3 => 3,
4 => 4,
5 => 5,
6 => 6,
7 => 7,
8 => 8,
9 => 9,
A => 10,
B => 11,
C => 12,
D => 13,
E => 14,
F => 15,
a => 10,
b => 11,
c => 12,
d => 13,
e => 14,
f => 15
};
=back
=head1 BENCHMARKS
Math::Base::Convert includes 2 development and one real world benchmark
sequences included in the test suite. Benchmark results for a 500mhz system
can be found in the 'benchmarks' source directory.
make test BENCHMARK=1
Provides comparison data for bi-directional conversion of an ascending
series of number strings in all base powers. The test sequence contains
number strings that go from a a single 32 bit register to several. Tested
bases are: (note: b32, b128, b256 not useful and are for testing only)
base 2 4 8 16 32 64 85 128 256
bin, dna, oct, hex, b32, b64, b85, b128, b256
Conversions are performed FROM all bases TO decimal and are repeated in the
opposing direction FROM decimal TO all bases.
Benchmark 1 results indicate the Math::Base::Convert typically runs
significantly faster ( 10x to 100x) than Math::BigInt based
implementations used in similar modules.
make test BENCHMARK=2
Provides comparison data for the frontend and backend converters in
Math::Base::Convert's CalcPP and Shortcuts packages, and Math::Bigint
conversions if it is present on the system under test.
make test BENCHMARK=3
Checks the relative timing of short and long number string conversions. FROM
a base number to n*32 bit register and TO a base number from an n*32 bit
register set.
i.e. strings that convert to and from 1, 2, 3... etc.. 32 bit registers
=head1 DEPENDENCIES
none
Math::BigInt is conditionally used in
the test suite but is not a requirement
=head1 EXPORT_OK
Conditional EXPORT functions
cnv
cnvabs
cnvpre
basemap
bin
oct
dec
heX
HEX
b62
b64
m64
iru
url
rex
id0
id1
xnt
xid
b85
ascii
=head1 EXPORT_TAGS
Conditional EXPORT function groups
:all => all of above
:base => all except 'cnv,cnvabs,cnvpre'
=head1 ACKNOWLEDGEMENTS
This module was inspired by Math::BaseConvert maintained by Shane Warden
<chromatic@cpan.org> and forked from Math::BaseCnv, both authored by Pip
Stuart <Pip@CPAN.Org>
=head1 AUTHOR
Michael Robinton, <miker@cpan.org>
=head1 COPYRIGHT
Copyright 2012-2015, Michael Robinton
This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
=cut
1;

163
database/perl/vendor/lib/Math/Base/Convert/Bases.pm vendored Normal file
View File

@@ -0,0 +1,163 @@
#!/usr/bin/perl
package Math::Base::Convert::Bases;
$VERSION = 0.03;
package Math::Base::Convert; # into the main package
@BASES = qw( bin dna DNA oct dec hex HEX b62 b64 m64 iru url rex id0 id1 xnt xid b85 ascii );
$signedBase = 16; # largest allowable known signed base
my $package = __PACKAGE__;
my $packageLen = length __PACKAGE__;
sub _class {
(my $class = (caller(1))[3]) =~ s/([^:]+)$/_bs::$1/;
$class;
}
my $callname = __PACKAGE__ . '::_bs::';
# return a pointer to a sub for the array blessed into Package::sub::name
#
my $_bin = bless ['0', '1'], $callname . 'bin';
my $_dna = bless [qw( a c t g )], $callname . 'dna';
my $_DNA = bless [qw( A C T G )], $callname . 'DNA';
my $_ocT = bless ['0'..'7'], $callname . 'ocT';
my $_dec = bless ['0'..'9'], $callname . 'dec';
my $_heX = bless ['0'..'9', 'a'..'f'], $callname . 'heX';
my $_HEX = bless ['0'..'9', 'A'..'F'], $callname . 'HEX';
my $_b62 = bless ['0'..'9', 'a'..'z', 'A'..'Z'], $callname . 'b62';
my $_b64 = bless ['0'..'9', 'A'..'Z', 'a'..'z', '.', '_'], $callname . 'b64';
my $_m64 = bless ['A'..'Z', 'a'..'z', '0'..'9', '+', '/'], $callname . 'm64';
my $_iru = bless ['A'..'Z', 'a'..'z', '0'..'9', '[', ']'], $callname . 'iru';
my $_url = bless ['A'..'Z', 'a'..'z', '0'..'9', '*', '-'], $callname . 'url';
my $_rex = bless ['A'..'Z', 'a'..'z', '0'..'9', '!', '-'], $callname . 'rex';
my $_id0 = bless ['A'..'Z', 'a'..'z', '0'..'9', '_', '-'], $callname . 'id0';
my $_id1 = bless ['A'..'Z', 'a'..'z', '0'..'9', '.', '_'], $callname . 'id1';
my $_xnt = bless ['A'..'Z', 'a'..'z', '0'..'9', '.', '-'], $callname . 'xnt';
my $_xid = bless ['A'..'Z', 'a'..'z', '0'..'9', '_', ':'], $callname . 'xid';
my $_b85 = bless ['0'..'9', 'A'..'Z', 'a'..'z', '!', '#', # RFC 1924 for IPv6 addresses, might need to return Math::BigInt objs
'$', '%', '&', '(', ')', '*', '+', '-', ';', '<', '=', '>', '?', '@', '^', '_', '`', '{', '|', '}', '~'], $callname . 'b85';
my $_ascii = bless [
' ','!','"','#','$','%','&',"'",'(',')','*','+',',','-','.','/',
'0','1','2','3','4','5','6','7','8','9',
':',';','<','=','>','?','@',
'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
'[','\\',']','^','_','`',
'a','b','c','d','e','f','g','h','i','j','k','l','m',
'n','o','p','q','r','s','t','u','v','w','x','y','z',
'{','|','}','~'], $callname . 'ascii'; # 7 bit printable ascii, base 96
#my $_ebcdic = bless [qw
# ( 0 1 2 3 37 2D 2E 2F 16 5 25 0B 0C 0D 0E 0F 10 11 12 13 3C 3D 32 26 18 19 3F 27 1C 1D 1E 1F
# 40 4F 7F 7B 5B 6C 50 7D 4D 5D 5C 4E 6B 60 4B 61 F0 F1 F2 F3 F4 F5 F6 F7 F8 F9 7A 5E 4C 7E 6E 6F
# 7C C1 C2 C3 C4 C5 C6 C7 C8 C9 D1 D2 D3 D4 D5 D6 D7 D8 D9 E2 E3 E4 E5 E6 E7 E8 E9 4A E0 5A 5F 6D
# 79 81 82 83 84 85 86 87 88 89 91 92 93 94 95 96 97 98 99 A2 A3 A4 A5 A6 A7 A8 A9 C0 6A D0 A1 7
# 20 21 22 23 24 15 6 17 28 29 2A 2B 2C 9 0A 1B 30 31 1A 33 34 35 36 8 38 39 3A 3B 4 14 3E E1 41
# 42 43 44 45 46 47 48 49 51 52 53 54 55 56 57 58 59 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
# 77 78 80 8A 8B 8C 8D 8E 8F 90 9A 9B 9C 9D 9E 9F A0 AA AB AC AD AE AF B0 B1 B2 B3 B4 B5 B6 B7 B8
# B9 BA BB BC BD BE BF CA CB CC CD CE CF DA DB DC DD DE DF EA EB EC ED EE EF FA FB FC FD FE FF)], $callname . 'ebcdic';
sub bin { $_bin }
sub dna { $_dna }
sub DNA { $_DNA }
sub ocT { $_ocT }
sub dec { $_dec }
sub heX { $_heX }
sub HEX { $_HEX }
sub b62 { $_b62 }
sub b64 { $_b64 }
sub m64 { $_m64 }
sub iru { $_iru }
sub url { $_url }
sub rex { $_rex }
sub id0 { $_id0 }
sub id1 { $_id1 }
sub xnt { $_xnt }
sub xid { $_xid }
sub b85 { $_b85 }
sub ascii { $_ascii }
#sub ebcdic { $_ebcdic }
# Since we're not using BIcalc, the last test can be eliminated...
################### special treatment for override 'hex' ##################################
sub hex {
# unless our package and is a BC ref and not a BI number (which is an ARRAY)
unless (ref($_[0]) && $package eq substr(ref($_[0]),0,$packageLen) && (local *glob = $_[0]) && *glob{HASH}) {
# $package, $filename, $line, $subroutine, $hasargs
# 0 1 2 3 4
# if defined and hasargs
if ( defined $_[0] && (caller(0))[4] ) {
return CORE::hex $_[0];
}
}
return heX();
}
################### special treatment for override 'oct' #################################
sub oct {
# unless our package and is a BC ref and not a BI number (which is an ARRAY)
unless (ref($_[0]) && $package eq substr(ref($_[0]),0,$packageLen) && (local *glob = $_[0]) && *glob{HASH}) {
# $package, $filename, $line, $subroutine, $hasargs
# 0 1 2 3 4
# if defined and hasargs
if ( defined $_[0] && (caller(0))[4] ) {
return CORE::oct $_[0];
}
}
return ocT();
}
################################## REMOVE ABOVE CODE ###################
# return a hash of all base pointers
#
sub _bases {
no strict;
my %bases;
foreach (@BASES) {
my $base = $_->();
ref($base) =~ /([^:]+)$/;
$bases{$1} = $base;
}
\%bases;
}
1;
__END__
=head1 NAME
Math::Base::Convert::Bases - helper module for bases
=head1 DESCRIPTION
This package contains no documentation
See L<Math::Base::Convert> instead
=head1 AUTHOR
Michael Robinton, michael@bizsystems.com
=head1 COPYRIGHT
Copyright 2012-2015, Michael Robinton
This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
=cut
1;

1159
database/perl/vendor/lib/Math/Base/Convert/Bitmaps.pm vendored Normal file
View File

File diff suppressed because it is too large Load Diff

231
database/perl/vendor/lib/Math/Base/Convert/CalcPP.pm vendored Normal file
View File

@@ -0,0 +1,231 @@
#!/usr/bin/perl
package Math::Base::Convert::CalcPP;
use strict;
use vars qw($VERSION);
$VERSION = do { my @r = (q$Revision: 0.03 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
# test number < 2^32 is NOT power of 2
#
sub isnotp2 {
my $ref = ref $_[0];
shift if ref $_[0] || $_[0] =~ /\D/; # class?
$_[0] & $_[0] -1;
}
# add a long n*32 bit number toa number < 65536
# add 'n' to array digits and propagate carry, return carry
#
sub addbaseno {
my($ap,$n) = @_;
foreach (@$ap) {
$_ += $n;
return 0 unless $_ > 0xffffffff;
$n = 1;
$_ -= 4294967296;
}
1; # carry is one on exit, else would have taken return 0 branch
}
# multiply a register of indeterminate length by a number < 65535
#
# ap pointer to multiplicand array
# multiplier
#
sub multiply {
my($ap,$m) = @_;
# $m is always 2..65535
# $m &= 0xffff; # max value 65535 already done by VETTING
#
# perl uses doubles for arithmetic, $m << 65536 will fit
my $carry = 0;
foreach ( @$ap) {
$_ *= $m;
$_ += $carry;
if ($_ > 0xffffffff) {
$carry = int($_ / 4294967296);
$_ %= 4294967296;
} else {
$carry = 0;
}
}
push @$ap, $carry if $carry;
}
sub dividebybase {
my($np,$divisor) = @_;
my @dividend = @$np; # 3% improvement
while ($#dividend) { # 3% improvement
last if $dividend[0];
shift @dividend;
}
my $remainder = 0;
my @quotient;
while (@dividend) {
my $work = ($dividend[0] += ($remainder * 4294967296));
push @quotient, int($work / $divisor);
$remainder = $work % $divisor;
shift @dividend;
}
return (\@quotient,$remainder);
}
# simple versions of conversion, works for N < ~2^49 or 10^16
#
#sub frombase {
# my($hsh,$base,$str) = @_;
# my $number = 0;
# for( $str =~ /./g ) {
# $number *= $base;
# $number += $hsh->{$_};
# }
# return $number;
#}
#sub tobase {
#sub to_base
# my($bp,$base,$num) = @_;
# my $base = shift;
# return $bp->[0] if $num == 0;
# my $str = '';
# while( $num > 0 ) {
# $str = $bp->[$num % $base] . $str;
# $num = int( $num / $base );
# }
# return $str;
#}
# convert a number from its base to 32*N bit representation
#
sub useFROMbaseto32wide {
my $bc = shift;
my($ary,$hsh,$base,$str) = @{$bc}{qw(from fhsh fbase nstr)};
# check if decimal and interger from within perl's 32bit double representation
# cutoff is 999,999,999,999,999 -- a bit less than 2^50
#
# convert directly to base 2^32 arrays
#
my @result = (0);
if ($base == 10 && length($str) < 16) {
# unless ($str > 999999999999999) { # maximum 32 bit double float integer representation
$result[0] = $str % 4294967296;
my $quotient = int($str / 4294967296);
$result[1] = $quotient if $quotient;
$bc->{b32str} = \@result;
}
else {
for ($str =~ /./g) {
multiply(\@result,$base);
push @result, 1 if addbaseno(\@result,$hsh->{$_}); # propagate carry
}
# my @rv = reverse @result;
$bc->{b32str} = \@result;
}
$bc;
}
#my %used = map {$_,0}(0..255);
# convert 32*N bit representation to any base < 65536
#
sub use32wideTObase {
my $bc = shift;
my($ary,$base,$rquot) = @{$bc}{qw(to tbase b32str)};
my @quotient = reverse(@$rquot);
my $quotient = \@quotient;
my @answer;
my $remainder;
do {
($quotient,$remainder) = dividebybase($quotient,$base);
# these commented out print statements are for convert.t DO NOT REMOVE!
#$used{$remainder} = 1;
#print $remainder;
#print " *" if $remainder > 86;
#print "\n";
unshift @answer, $ary->[$remainder];
} while grep {$_} @$quotient;
#foreach (sort {$b <=> $a} keys %used) {
#print " $_,\n" if $used{$_} && $_ > 85;
#print "\t$_\t=> \n" if !$used{$_} && $_ < 86;
#}
join '', @answer;
}
1;
__END__
=head1 NAME
Math::Base::Convert::CalcPP - standard methods used by Math::Base::Convert
=head1 DESCRIPTION
This module contains the standard methods used by B<Math::Base::Convert> to
convert from one base number to another base number.
=over 4
=item * $carry = addbaseno($reg32ptr,$int)
This function adds an integer < 65536 to a long n*32 bit register and
returns the carry.
=item * multiply($reg32ptr,$int)
This function multiplies a long n*32 bit register by an integer < 65536
=item * ($qptr,$remainder) = dividebybase($reg32ptr,$int)
this function divides a long n*32 bit register by an integer < 65536 and
returns a pointer to a long n*32 bit quotient and an integer remainder.
=item * $bc->useFROMbaseto32wide
This method converts FROM an input base string to a long n*32 bit register using
an algorithim like:
$longnum = 0;
for $char ( $in_str =~ /./g ) {
$longnum *= $base;
$longnum += $value{$char)
}
return $number;
=item * $output = $bc->use32wideTObase
This method converts a long n*32 bit register TO a base number using an
algorithim like:
$output = '';
while( $longnum > 0 ) {
$output = ( $longnum % $base ) . $output;
$num = int( $longnum / $base );
}
return $output;
=back
=head1 AUTHOR
Michael Robinton, michael@bizsystems.com
=head1 COPYRIGHT
Copyright 2012-15, Michael Robinton
This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
=cut
1;

462
database/perl/vendor/lib/Math/Base/Convert/Shortcuts.pm vendored Normal file
View File

@@ -0,0 +1,462 @@
package Math::Base::Convert::Shortcuts;
use vars qw($VERSION);
use strict;
$VERSION = do { my @r = (q$Revision: 0.05 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
# load bitmaps
my $xlt = require Math::Base::Convert::Bitmaps;
#
# base 2 4 8 16 32 64
# base power 1 2 3 4 5 6
# xlt = [ \@standardbases, undef, \%_2wide, undef, undef, \%_5wide, \%_6wide ];
#
# base 2 maps directly to lookup key
# base 3 maps directly to standard lookup value
# base 4 converts directly to hex
#
# where @standardbases = (\{
# dna => {
# '00' => 'a',
# '01' => 'c',
# '10' => 't',
# '11' => 'g',
# },
# b64 => {
# '000000' => 0,
# '000001' => 1,
# * -
# * -
# '001010' => 'A',
# '001011' => 'B',
# * -
# * -
# '111111' => '_',
# },
# m64 => etc....
# iru
# url
# rex
# id0
# id1
# xnt
# xid
# });
#
# .... and
#
# hash arrays are bit to value maps of the form
#
# %_3wide = {
# '000' => 0,
# '001' => 1,
# '010' => 2,
# * -
# * -
# etc...
# };
#
my @srindx = ( # accomodate up to 31 bit shifts
0, # 0 unused
1, # 1
3, # 2
7, # 3
0xf, # 4
0x1f, # 5
0x3f, # 6
0x7f, # 7
0xff, # 8
0x1ff, # 9
0x3ff, # 10
0x7ff, # 11
0xfff, # 12
0x1fff, # 13
0x3fff, # 14
0x7fff, # 15
0xffff, # 16
0x1ffff, # 17
0x3ffff, # 18
0x7ffff, # 19
0xfffff, # 20
0x1fffff, # 21
0x3fffff, # 22
0x7fffff, # 23
0xffffff, # 24
0x1ffffff, # 25
0x3ffffff, # 26
0x7ffffff, # 27
0xfffffff, # 28
0x1fffffff, # 29
0x3fffffff, # 30
0x7fffffff # 31
);
my @srindx2 = ( # accomodate up to 31 bit shifts
0xffffffff, # 0 unused
0xfffffffe, # 1
0xfffffffc, # 2
0xfffffff8, # 3
0xfffffff0, # 4
0xffffffe0, # 5
0xffffffc0, # 6
0xffffff80, # 7
0xffffff00, # 8
0xfffffe00, # 9
0xfffffc00, # 10
0xfffff800, # 11
0xfffff000, # 12
0xffffe000, # 13
0xffffc000, # 14
0xffff8000, # 15
0xffff0000, # 16
0xfffe0000, # 17
0xfffc0000, # 18
0xfff80000, # 19
0xfff00000, # 20
0xffe00000, # 21
0xffc00000, # 22
0xff800000, # 23
0xff000000, # 24
0xfe000000, # 25
0xfc000000, # 26
0xf8000000, # 27
0xf0000000, # 28
0xe0000000, # 29
0xc0000000, # 30
0x80000000 # 31
);
#
# $arraypointer, $shiftright, $mask, $shiftleft
#
sub longshiftright {
my $ap = $_[0]; # perl appears to optimize these variables into registers
my $sr = $_[1]; # when they are set in this manner -- much faster!!
my $msk = $_[2];
my $sl = $_[3];
my $al = $#$ap -1;
my $i = 1;
foreach (0..$al) {
$ap->[$_] >>= $sr;
# $ap->[$_] |= ($ap->[$i] & $msk) << $sl;
$ap->[$_] |= ($ap->[$i] << $sl) & $msk;
$i++;
}
$ap->[$#$ap] >>= $sr;
}
# see the comments at "longshiftright" about the
# integration of calculations into the local subroutine
#
sub shiftright {
my($ap,$n) = @_;
longshiftright($ap,$n,$srindx2[$n],32 -$n);
}
#
# fast direct conversion of base power of 2 sets to base 2^32
#
sub bx1 { # base 2, 1 bit wide x32 = 32 bits - 111 32 1's 111111111111111
my($ss,$d32p) = @_;
unshift @$d32p, unpack('N1',pack('B32',$ss));
}
my %dna= ('AA', 0, 'AC', 1, 'AT', 2, 'AG', 3, 'CA', 4, 'CC', 5, 'CT', 6, 'CG', 7, 'TA', 8, 'TC', 9, 'TT', 10, 'TG', 11, 'GA', 12, 'GC', 13, 'GT', 14, 'GG', 15,
'Aa', 0, 'Ac', 1, 'At', 2, 'Ag', 3, 'Ca', 4, 'Cc', 5, 'Ct', 6, 'Cg', 7, 'Ta', 8, 'Tc', 9, 'Tt', 10, 'Tg', 11, 'Ga', 12, 'Gc', 13, 'Gt', 14, 'Gg', 15,
'aA', 0, 'aC', 1, 'aT', 2, 'aG', 3, 'cA', 4, 'cC', 5, 'cT', 6, 'cG', 7, 'tA', 8, 'tC', 9, 'tT', 10, 'tG', 11, 'gA', 12, 'gC', 13, 'gT', 14, 'gG', 15,
'aa', 0, 'ac', 1, 'at', 2, 'ag', 3, 'ca', 4, 'cc', 5, 'ct', 6, 'cg', 7, 'ta', 8, 'tc', 9, 'tt', 10, 'tg', 11, 'ga', 12, 'gc', 13, 'gt', 14, 'gg', 15,
);
# substr 4x faster than array lookup
#
sub bx2 { # base 4, 2 bits wide x16 = 32 bits - 3333333333333333
my($ss,$d32p) = @_;
my $bn = $dna{substr($ss,0,2)}; # 2 digits as a time => base 16
$bn <<= 4;
$bn += $dna{substr($ss,2,2)};
$bn <<= 4;
$bn += $dna{substr($ss,4,2)};
$bn <<= 4;
$bn += $dna{substr($ss,6,2)};
$bn <<= 4;
$bn += $dna{substr($ss,8,2)};
$bn <<= 4;
$bn += $dna{substr($ss,10,2)};
$bn <<= 4;
$bn += $dna{substr($ss,12,2)};
$bn <<= 4;
$bn += $dna{substr($ss,14,2)};
unshift @$d32p, $bn;
}
sub bx3 { # base 8, 3 bits wide x10 = 30 bits - 07777777777
my($ss,$d32p) = @_;
unshift @$d32p, CORE::oct($ss) << 2;
shiftright($d32p,2);
}
sub bx4 { # base 16, 4 bits wide x8 = 32 bits - 0xffffffff
my($ss,$d32p) = @_;
unshift @$d32p, CORE::hex($ss);
}
sub bx5 { # base 32, 5 bits wide x6 = 30 bits - 555555
my($ss,$d32p,$hsh) = @_;
my $bn = $hsh->{substr($ss,0,1)};
$bn <<= 5;
$bn += $hsh->{substr($ss,1,1)};
$bn <<= 5;
$bn += $hsh->{substr($ss,2,1)};
$bn <<= 5;
$bn += $hsh->{substr($ss,3,1)};
$bn <<= 5;
$bn += $hsh->{substr($ss,4,1)};
$bn <<= 5;
unshift @$d32p, ($bn += $hsh->{substr($ss,5,1)}) << 2;
shiftright($d32p,2);
}
sub bx6 { # base 64, 6 bits wide x5 = 30 bits - 66666
my($ss,$d32p,$hsh) = @_;
my $bn = $hsh->{substr($ss,0,1)};
$bn <<= 6;
$bn += $hsh->{substr($ss,1,1)};
$bn <<= 6;
$bn += $hsh->{substr($ss,2,1)};
$bn <<= 6;
$bn += $hsh->{substr($ss,3,1)};
$bn <<= 6;
unshift @$d32p, ($bn += $hsh->{substr($ss,4,1)}) << 2;
shiftright($d32p,2);
}
sub bx7 { # base 128, 7 bits wide x4 = 28 bits - 7777
my($ss,$d32p,$hsh) = @_;
my $bn = $hsh->{substr($ss,0,1)};
$bn <<= 7;
$bn += $hsh->{substr($ss,1,1)};
$bn <<= 7;
$bn += $hsh->{substr($ss,2,1)};
$bn <<= 7;
unshift @$d32p, ($bn += $hsh->{substr($ss,3,1)}) << 4;
shiftright($d32p,4);
}
sub bx8 { # base 256, 8 bits wide x4 = 32 bits - 8888
my($ss,$d32p,$hsh) = @_;
my $bn = $hsh->{substr($ss,0,1)};
$bn *= 256;
$bn += $hsh->{substr($ss,1,1)};
$bn *= 256;
$bn += $hsh->{substr($ss,2,1)};
$bn *= 256;
unshift @$d32p, $bn += $hsh->{substr($ss,3,1)};
}
my @useFROMbaseShortcuts = ( 0, # unused
\&bx1, # base 2, 1 bit wide x32 = 32 bits - 111 32 1's 111111111111111
\&bx2, # base 4, 2 bits wide x16 = 32 bits - 3333333333333333
\&bx3, # base 8, 3 bits wide x10 = 30 bits - 07777777777
\&bx4, # base 16, 4 bits wide x8 = 32 bits - 0xffffffff
\&bx5, # base 32, 5 bits wide x6 = 30 bits - 555555
\&bx6, # base 64, 6 bits wide x5 = 30 bits - 66666
\&bx7, # base 128, 7 bits wide x4 = 28 bits - 7777
\&bx8, # and base 256, 8 bits wide x4 = 32 bits - 8888
);
# 1) find number of digits of base that will fit in 2^32
# 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
}
$L *= 32;
(my $bits = unpack("B$L",$packed)) =~ s/^0+//; # suppress leading zeros
#print "bp = $bp, BITS=\n$bits\n";
my $len = length($bits);
my $m = $len % $bp; # pad to even multiple base power
#my $z = $m;
if ($m) {
$m = $bp - $m;
$bits = ('0' x $m) . $bits;
$len += $m;
}
#print "len = $len, m_init = $z, m = $m, BITS PADDED\n$bits\n";
$str = '';
for (my $i = 0; $i < $len; $i += $bp) {
$str .= $map->{substr($bits,$i,$bp)};
#print "MAPPED i=$i, str=$str\n";
}
}
$str;
}
1;
__END__
=head1 NAME
Math::Base::Convert::Shortcuts - methods for converting powers of 2 bases
=head1 DESCRIPTION
This module contains two primary methods that convert bases that are exact
powers of 2 to and from base 2^32 faster than can be done by pure perl math.
=over 4
=item * $bc->useFROMbaseShortcuts
This method converts FROM an input base number to a long n*32 bit register
=item * $output = $bc->useTObaseShortcuts;
This method converts an n*32 bit registers TO an output base number.
=item * EXPORTS
None
=back
=head1 AUTHOR
Michael Robinton, michael@bizsystems.com
=head1 COPYRIGHT
Copyright 2012-2015, Michael Robinton
This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
=cut
1;