#!/opt/local/bin/perl -w
=pod
# --------------------------------------------------------------------
  The software provided here is released by the National
  Institute of Standards and Technology (NIST), an agency of
  the U.S. Department of Commerce, Gaithersburg MD 20899,
  USA.  The software bears no warranty, either expressed or
  implied. NIST does not assume legal liability nor
  responsibility for a User's use of the software or the
  results of such use.
  
  Please note that within the United States, copyright
  protection, under Section 105 of the United States Code,
  Title 17, is not available for any work of the United
  States Government and/or for any works created by United
  States Government employees. User acknowledges that this
  software contains work which was created by NIST employees
  and is therefore in the public domain and not subject to
  copyright.  The User may use, distribute, or incorporate
  this software provided the User acknowledges this via an
  explicit acknowledgment of NIST-related contributions to
  the User's work. User also agrees to acknowledge, via an
  explicit acknowledgment, that any modifications or
  alterations have been made to this software before
  redistribution.
# --------------------------------------------------------------------
=cut


=pod
This code reduces an input file to a group of meta-characters.

I chose the 8 characters below because the low order bits can 
be used in future in a digest that I have in mind.
 @ block boundary
 A alphanumeric
 B binary (above 0x7f / 0177 UNLESS in UTF-16 mode)
 C control chars (below 0x20 / 0040)
 D whitespace
 E 0x00
 F 0xff
 G other (TBD)

Mapping into a set that can take advantage of perlbio algorithms
might be useful.

UTF-16 (and -32?) need to be fleshed out.

Entropy calculation needs to be fleshed out.
=cut

use strict;
use Getopt::Std;
use vars qw( $opt_M $opt_h $opt_U $opt_i $opt_o $opt_b $opt_n $bsize 
             $utf $data $bcount %count $mstr );
    my $LOBLOCK = 64;
    my $HIBLOCK = 8192;
    %count = ( '@', 0,
               'A', 0,
               'B', 0,
               'C', 0,
               'D', 0,
               'E', 0,
               'F', 0,
               'G', 0 );
    $mstr ='';

# -- command line arguments
    getopts('hnMU:i:o:b:') or $opt_h = 1;

    if (! $opt_i) { giveHelp("input file is MANDATORY"); }
    if (! -e "$opt_i") { giveHelp("input file does not exist: $opt_i"); }
    if (-e "$opt_o") { giveHelp("output file cannot be overwritten: $opt_o"); }
    if (defined $opt_b) {
        $bsize = int($opt_b);
        if (($bsize < $LOBLOCK) || ($bsize > $HIBLOCK)) { 
            giveHelp("block size ($opt_b) must range from $LOBLOCK to $HIBLOCK"); }
    }
    else {
        $bsize = 4096;  # default
    }
    if (defined $opt_U) {
        $utf = int($opt_U);
        if (($utf != 8) && ($utf != 16)) {
            giveHelp("UTF size ($opt_U) must be 8 or 16"); }
    }
    else {
        $utf = 8;  # default
    }
    if ($opt_h) { giveHelp("help"); }

# -- hack for now
    if ($utf != 8) {
        giveHelp("UTF size ($utf) is not supported yet"); }

# -- file I/O
    open(FIN,"$opt_i") or die "$0 : cannot open input file $opt_i for reading\n";
    if ($opt_M) {
        open(FOUT,">$opt_o") or die "$0 : cannot open output file $opt_o for writing\n";
    }

# -- process the file by blocks
    $bcount=0; # this is redundant with $count{'@'}
    while(read(FIN,$data,$bsize)) {
        while (length($data)) {
            my $known = 0;
            if ($data =~ /^(\000+)/ ) { notate('E', length($1)); $known=1; }
            if ($data =~ /^(\377+)/ ) { notate('F', length($1)); $known=1; }
            if ($data =~ /^([\d\w]+)/ ) { notate('A', length($1)); $known=1; }
            if ($data =~ /^([\001-\037]+)/ ) { notate('C', length($1)); $known=1; }
            if ($data =~ /^([\200-\376]+)/ ) { notate('B', length($1)); $known=1; }
            if ($data =~ /^(\s+)/ ) { notate('D', length($1)); $known=1; }
            if (! $known) { notate('G', 1); }
        }
        if (! $opt_M) {
            $mstr .= '@';
            if ($opt_n) { $mstr .= "\n"; }
        }
        else {
            print FOUT '@';
            if ($opt_n) { print FOUT "\n"; }
        }
        $bcount++;
        $count{'@'}++;
    }
    close(FIN);
# -- file output if built in memory
    if (! $opt_M) {
        open(FOUT,">$opt_o") or die "$0 : cannot open output file $opt_o for writing\n";
        print FOUT $mstr ;
    }
    close(FOUT);

# -- print some stats
    print STDERR "\n$0 summary $opt_i : $bcount $bsize blocks";
    my $cc = 0;
    for my $k (sort {$a cmp $b} (keys %count)) {
        print STDERR ", $k $count{$k}";
        if ($k ne '@') { $cc += $count{$k}; }
    }
    print STDERR ", chars $cc\n";

exit;


# -- usage help, and warnings

sub giveHelp {
    my $msg = shift;
    if (defined $msg && ($msg ne 'help')) {
        print STDERR "$0  Warning : $msg\n";
    }

    print STDERR <<EOH ;
Usage : $0 -i file [-o file] [-U 8|16] [-b blocksize] [-h]
  -i infile  : MANDATORY
  -o outfile : will not overwrite existing file
  -U [8|16]  : force to UTF-8 or -16
  -b integer : block size
  -n         : add newline in output at block breaks
  -M         : do NOT build results in memory, write on the fly
  -h         : help
EOH
    exit;

}


=pod
 @ block boundary
 A alphanumeric
 B binary (above 0x7f / 0177 UNLESS in UTF-16 mode)
 C control chars (below 0x20 / 0040)
 D whitespace
 E 0x00
 F 0xff
 G other (punctuation, other printable?)
=cut

# -- print the meta notation

sub notate {
    my $c = shift;
    my $n = shift;

    if ((! defined $c) || (! defined $n)) { 
        close(FIN);
        if ($opt_M) { close(FOUT); }
        print STDERR "$0 : FATAL ERROR in sub notate\n";
        exit;
    }

    $count{$c} += $n; 
    substr($data,0,$n) = '';    # dangerous
    if (! $opt_M) {
        $mstr .= $c;
    } else {
        print FOUT "$c";
    }
    return(0);
}

__END__




##</code><code>##

#!/usr/bin/perl
# Edit the line above and line below for your perl path
#    eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
#        if 0; #$running_under_some_shell

# --------------------------------------------------------------------
# The software provided here is released by the National
# Institute of Standards and Technology (NIST), an agency of
# the U.S. Department of Commerce, Gaithersburg MD 20899,
# USA.  The software bears no warranty, either expressed or
# implied. NIST does not assume legal liability nor
# responsibility for a User's use of the software or the
# results of such use.
# 
# Please note that within the United States, copyright
# protection, under Section 105 of the United States Code,
# Title 17, is not available for any work of the United
# States Government and/or for any works created by United
# States Government employees. User acknowledges that this
# software contains work which was created by NIST employees
# and is therefore in the public domain and not subject to
# copyright.  The User may use, distribute, or incorporate
# this software provided the User acknowledges this via an
# explicit acknowledgment of NIST-related contributions to
# the User's work. User also agrees to acknowledge, via an
# explicit acknowledgment, that any modifications or
# alterations have been made to this software before
# redistribution.
# --------------------------------------------------------------------
#   douglas.white@nist.gov
#
# Usage :   perl sha-family.pl [-h] [-u] -f Family_String filename [filename...]
#
#           -h : will show help
#           -u : will display hash in uppercase (if allowed)
#           -f Family_String : comma separated list of output you want
#                              e.g.  "all" or "sha1_hex,sha1_b64,sha256_hex"
#
# updated 3/28/10
# --------------------------------------------------------------------
# Test this against the NIST FIPS data before you use it!
# 
# http://csrc.nist.gov/
# http://www.nsrl.nist.gov/testdata/
# --------------------------------------------------------------------

use strict;
use warnings;
use vars qw( $opt_h $opt_u $opt_f %family $fileName );
use Getopt::Std ;
use Digest::SHA ;

# Deal with command line options. Give help if needed.
getopts('huf:') or $opt_h=1;
($opt_f) or $opt_f='all';
(checkHashFamilies($opt_f)) or $opt_h=1;
if ($opt_h) { showHelpAndExit(); }

$fileName = shift;
while($fileName) { hashAndPrint(); $fileName = shift; };

exit;


#------------------------------------------

sub hashAndPrint {

(-e "$fileName") or return(0); # file must exist
(! -d "$fileName") or return(0); # must not be a directory
# 2G file size limit for now - increase at your own risk/memory available.
((-s "$fileName") < (2 * 1024 * 1024 * 1024)) or return(0);

use vars qw( @fks );

@fks = (sort keys %family);

#
# You need to delare a new() SHA object based on the algorithm,
# so her I'm finding out which algorithms were requested.
#
for my $f (@fks) {
   if (($f =~ /sha1/ ) && ($family{$f})) { calcDigest(1); }
   if (($f =~ /sha224/ ) && ($family{$f})) { calcDigest(224); }
   if (($f =~ /sha256/ ) && ($family{$f})) { calcDigest(256); }
   if (($f =~ /sha384/ ) && ($family{$f})) { calcDigest(384); }
   if (($f =~ /sha512/ ) && ($family{$f})) { calcDigest(512); }
} 

return(1);
}


 #----------------------------------------------

sub calcDigest {
    my $mode = shift;
    my $inFile;

    if (!open ($inFile, '<', $fileName)) {
        print STDERR "$0 : cannot open file \"$fileName\"\n";
        return 0;
    }
    binmode $inFile;
    my $dObj = Digest::SHA->new ($mode);
    my $digest;
    if ($family{"sha$mode"}) {
        $family{"sha$mode"} = 0;
        $dObj->addfile ($inFile);
        $digest = $dObj->digest;
        my $ps = unpack ("B*", $digest);
        my $l = $mode;
        if ($mode == 1) { $l = 160;} # SHA-1 (1) has 160 bits
        while (length ($ps) < $l) {$ps = "0$ps";}
        print "sha$mode($fileName)= $ps\n";
        seek ($inFile, 0, 0);
    }
    if ($family{"sha${mode}_hex"}) {
        $family{"sha${mode}_hex"} = 0;
        $dObj->addfile ($inFile);
        $digest = lc ($dObj->hexdigest);
        if ($opt_u) {$digest = uc ($digest);}
        print "sha${mode}_hex($fileName)= $digest\n";
        seek ($inFile, 0, 0);
    }
    if ($family{"sha${mode}_b64"}) {
        $family{"sha${mode}_b64"} = 0;
        $dObj->addfile ($inFile);
        $digest = $dObj->b64digest;
        while (length ($digest) % 4) {$digest .= '=';}
        print "sha${mode}_b64($fileName)= $digest\n";
    }
    close ($inFile);
}


 #----------------------------------------------

sub checkHashFamilies {

my $f = shift;
($f) or return(0);
%family = (
    'sha1' => 0,
    'sha1_hex' => 0,
    'sha1_b64' => 0,
    'sha224' => 0,
    'sha224_hex' => 0,
    'sha224_b64' => 0,
    'sha256' => 0,
    'sha256_hex' => 0,
    'sha256_b64' => 0,
    'sha384' => 0,
    'sha384_hex' => 0,
    'sha384_b64' => 0,
    'sha512' => 0,
    'sha512_hex' => 0,
    'sha512_b64' => 0
          );

if ($f eq 'all') {
   for my $k (keys %family) { $family{$k} = 1; }
   return(1);
}

my @p = split(/,/,$f);
for my $k (@p) {
   if (! defined $family{$k}) { return(0); } # tried using unknown family
   $family{$k} = 1;
}
return(1);

}

 #----------------------------------------------

sub showHelpAndExit {

print <<EOH;

Usage :   perl sha-family.pl [-h] [-u] -f Family_String filename [filename...]

      -h : will show help
      -u : will display hash in uppercase (if allowed)
      -f Family_String : comma separated list of output you want
                         e.g.  "all" or "sha1_hex,sha1_b64,sha256_hex"
Valid family strings:
EOH
print join(",",(keys %family)), "\n";
exit;

}

 #----------------------------------------------

__END__


The Secure Hash Algorithms (SHA-1, SHA-224, SHA-256, SHA-384, 
and SHA-512) are specified in  FIPS 180-2 with Change Notice 1 
dated February 25, 2004, Secure Hash Standard (SHS).

Within FIPS 180-2 are SHA-1 example messages.

    * Let the message be the ASCII string "abc". [file] 
      The resulting 160-bit message digest is a9993e36 4706816a ba3e2571 7850c26c 9cd0d89d.
    * Let the message be the ASCII string "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq". [file] 
      The resulting 160-bit message digest is 84983e44 1c3bd26e baae4aa1 f95129e5 e54670f1.
    * Let the message be the binary-coded form of the ASCII string which consists of 1,000,000 repetitions of the character "a". [file] 
      The resulting SHA-1 message digest is 34aa973c d4c4daa4 f61eeb2b dbad2731 6534016f. 

If the SHA-1 implementation you are using does not yield the 
expected results shown above for the example message strings, 
you may have a problem.

For the sake of informal testing, here are the SHA-256 equivalents of the same message strings:

    * Let the message be the ASCII string "abc". [file] 
      The resulting 256-bit message digest is BA7816BF 8F01CFEA 414140DE 5DAE2223 B00361A3 96177A9C B410FF61 F20015AD.
    * Let the message be the ASCII string "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq". [file] 
      The resulting 256-bit message digest is 248D6A61 D20638B8 E5C02693 0C3E6039 A33CE459 64FF2167 F6ECEDD4 19DB06C1.
    * Let the message be the binary-coded form of the ASCII string which consists of 1,000,000 repetitions of the character "a". [file] 
      The resulting SHA-256 message digest is CDC76E5C 9914FB92 81A1C7E2 84D73E67 F1809A48 A497200E 046D39CC C7112CD0. 

If the SHA-256 implementation you are using does not yield the 
expected results shown above for the example message strings, 
you may have a problem. 


##</code><code>##

#!/usr/bin/perl -w

# dwhite@nist.gov 3/23/04  - based on BASIC code
# in "Astronomical Algorithms" 2nd ed. by Jean Meeus, pg 17-19

use strict;
use vars qw( $opt_v $x $j $pi );

$opt_v = shift;
if ((defined $opt_v) && ($opt_v ne "-v")) {
    die "Usage: $0 [-v]\n\tthis calculates the internal accuracy\n\tof the programming language.  -v is verbose\n";
}

# log info about this machine
# print "$0 : you appear to be using \n";
# print "\tVENDOR   \t\"$ENV{VENDOR}\"\n";
# print "\tMACHTYPE \t\"$ENV{MACHTYPE}\"\n";
# print "\tOSTYPE   \t\"$ENV{OSTYPE}\"($^O)\"\n";
# print "$0 : you appear to be using \n\tVENDOR   \t\"$ENV{VENDOR}\"\n\tMACHTYPE \t\"$ENV{MACHTYPE}\"\n\tOSTYPE   \t\"$ENV{OSTYPE}\"($^O)\"\n\tHOSTTYPE \t$ENV{HOSTTYPE}\" \n";

# start of code block 1
$x = 1 ;
$j = 0 ;
$x *= 2 ;
if (defined $opt_v) { print "Testing significant bits, significant digits...\n"; }
while (($x + 1) != $x) {
if (defined $opt_v) { print "\t$j\t$x\n"; }
$j++ ;
$x *= 2 ;
}
if (defined $opt_v) { print "\t$j\t$x\n"; }
print "\n", $j , " significant bits in mantissa of floating number\n" , int($j * 0.30103) , " significant digits in a decimal number (", $j * 0.30103 , ")\n above is only for SIMPLE ARITHMETICS, not trig functions!\n";
# end of code block 1

# simple pi check
$pi = atan2(1,1) * 4 ;
print "\narctan(1)*4 [aka pi] is $pi \n check this against     3.141592653589793238462643383279502\n";

print "\nthe 2nd column here should NOT list diverging numbers...\n";
print "\$x=1.0/3.0;  for(\$j=1;\$j<31;\$j++) { \$x = (9*\$x+1)*\$x-1 ; }\n";
# start of code block 2
$x = 1.0/3.0 ;
for($j=1;$j<31;$j++) {
    $x = (9*$x+1)*$x-1 ;
    if (defined $opt_v) { print "$j\t$x\n"; }
    if ((!defined $opt_v) && ($j % 6 == 1)) { print "$j\t$x\n"; }
}
print "However, they probably will diverge on your machine.\n";
# end of code block 2

# another simple check pg. 18
print "\nsquare 1.0000001 27 times...\n";
$x = 1.0000001 ;
for($j=0;$j<27;$j++) {
    $x *= $x ;
}
print "674530.4707 is the expected result to 10 sigdigs,\n$x is your calculated result\n";

# more quick checks pg. 19
print "\n\$x = 4.34 ; \$j = int(100*(\$x-int(\$x))); ";
$x = 4.34 ;
$j = int(100*($x-int($x)));
print "\n\$j should be 34 and you calculated \$j to be $j \n";

# the order of the addition in these 2 tests can be a factor
print "\n2 + 0.2 + 0.2 + 0.2 + 0.2 + 0.2 - 3 = 0 and you get ";
print 2 +0.2 +0.2 +0.2 +0.2 +0.2 -3 , "\n";

print "0.2 + 0.2 + 0.2 + 0.2 + 0.2 + 2 - 3 = 0 and you get ";
print 0.2 +0.2 +0.2 +0.2 +0.2 +2 -3 , "\n";

print "2 + (5 * 0.2) - 3 = 0 and you get ";
print 2 + (5*0.2) -3 , "\n";

# start of code block 3
for($j=0;$j<=100;$j+=0.1) {
    $x = $j;
}
print "\nfor(\$j=0;\$j<=100;\$j+=0.1) { \$x = \$j; } ";
print "\n$x should equal 100\n";
# end of code block 3

# page 20
# another simple check - try big numbers or 2**x-1
# 255, 65535, 16777215, 4294967295, 1099511627775 = 2**(8*x)
print "\nSimple test that may fail with large numbers:\n";
my @a = ( 255, 65535, 16777215, 4294967295, 1099511627775, 281474976710655 );
for ($j=0;$j<=$#a;$j++) {
    my $b = $a[$j]/10 ; my $c = 10 * $b ;
    print "\$a = $a[$j]; \$b = \$a/10 ; \$c = 10 * \$b ; \$a -\$c = ", $a[$j]-$c , " = 0\n";
}

# page 20 
print "\nsqrt(25)-5 = ", sqrt(25)-5 , " : should be 0\n";
print "sqrt(25)-int(sqrt(25)) = ", sqrt(25)-int(sqrt(25)) , " : should be 0\n";


print "\n";
exit;

__END__

original code is

# start of code block 1
10 x=1
20 j=0
30 x=x*2
40 if x+1 <> x then 60
50 goto 80
60 j=j+1
70 goto 30
80 print j, j*0.30103
90 end
# end of code block 1

# start of code block 2
10 x=1/3
20 for j=1 to 30
30 x=(9*x+1)*x-1
40 print j,x
50 next j
60 end
# end of code block 2

# start of code block 3
10 for i=0 to 100 step 0.1
20 u=i
30 next i
40 print u
50 end
# end of code block 3

##</code><code>##

#!c:\perl\bin\perl -w
use strict;
use Win32::Process;

# one example of use - works on Win2000, Active State 5.6.1
system("echo dir c:\\ /o/s/w > c:\\temp\\dir_osw.bat");
if (-e "c:\\temp\\dir_osw.bat") {
    run_monitored(10,"c:\\temp\\dir_osw.bat");
}
else {
    print "\nbuild the batch file by hand, or hack the code.\n";
}

exit;

# --------

# call with int # of seconds to wait, explicit path to command to run
# lifted from Dave Roth's "Win32 Perl Programming: the Standard Extensions"
# pages 290-300   ISBN 1-57870-067-1

sub run_monitored {

use vars qw( $Process $Timeout $File $App $Cmd 
             $bInherit $Dir $Flag $Pid $Result $tmp );

$Timeout = int( shift @_ );
$App = shift @_ ;
$File = " " ;
$Cmd = "$App $File";
$bInherit = 0;
$Dir = ".";
# IDLE_PRIORITY_CLASS - run when idle
# NORMAL_PRIORITY_CLASS - as if normal process
# HIGH_PRIORITY_CLASS - more CPU, other procs suffer
# REALTIME_PRIORITY_CLASS - take over the PC
$Flag = CREATE_SUSPENDED | CREATE_NEW_CONSOLE | NORMAL_PRIORITY_CLASS ;
if (Win32::Process::Create( $Process, $App, $Cmd, $bInherit, $Flag, $Dir ) ) {
    $Pid = $Process->GetProcessID();
#    print "\nnew process created in suspended state";
#    print "\n$Cmd";
#    print "\nwith an ID of $Pid , now resuming the process...\n";
    print "\nnew process created with PID $Pid";
    while (1 < $Process->Resume() ) { }
    print "\nwaiting $Timeout seconds ... ";
    $Result = $Process->Wait($Timeout * 1000);
    if (! $Result) {
        print "did not end in $Timeout sec, kill it \cG\cG\cG";
	$Process->Kill(0);
    }
    else {
        print "finished under $Timeout sec.";
    }
}
else {
    print "\nunable to create the new process.\n";
    print "Error: " .  Win32::FormatMessage(Win32::GetLastError()) . "\n\cG";
}

} # run_monitored