Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

dwhite20899's scratchpad

by dwhite20899 (Pilgrim)
on Jun 13, 2004 at 01:01 UTC ( #363690=scratchpad: print w/ replies, xml ) Need Help??

### 2012-06-15 - Meta-char code
#!/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: $o +pt_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)); $know +n=1; } if ($data =~ /^(\377+)/ ) { notate('F', length($1)); $know +n=1; } if ($data =~ /^([\d\w]+)/ ) { notate('A', length($1)); $kn +own=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__
##### SHA family 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 [fi +lename...] # # -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,sha25 +6_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 availa +ble. ((-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 fam +ily $family{$k} = 1; } return(1); } #---------------------------------------------- sub showHelpAndExit { print <<EOH; Usage : perl sha-family.pl [-h] [-u] -f Family_String filename [file +name...] -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 ba3e25 +71 7850c26c 9cd0d89d. * Let the message be the ASCII string "abcdbcdecdefdefgefghfghighi +jhijkijkljklmklmnlmnomnopnopq". [file] The resulting 160-bit message digest is 84983e44 1c3bd26e baae4a +a1 f95129e5 e54670f1. * Let the message be the binary-coded form of the ASCII string whi +ch 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 414140 +DE 5DAE2223 B00361A3 96177A9C B410FF61 F20015AD. * Let the message be the ASCII string "abcdbcdecdefdefgefghfghighi +jhijkijkljklmklmnlmnomnopnopq". [file] The resulting 256-bit message digest is 248D6A61 D20638B8 E5C026 +93 0C3E6039 A33CE459 64FF2167 F6ECEDD4 19DB06C1. * Let the message be the binary-coded form of the ASCII string whi +ch consists of 1,000,000 repetitions of the character "a". [file] The resulting SHA-256 message digest is CDC76E5C 9914FB92 81A1C7 +E2 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.
##### accuracy 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 dig +its...\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 func +tions!\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.14159 +2653589793238462643383279502\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 c +alculated 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, 28147497671 +0655 ); 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
#### Win32 stuff
#!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 Extens +ions" # 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, $D +ir ) ) { $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
Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (7)
As of 2014-08-01 01:50 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (256 votes), past polls