Paranoid-2.10/0000750000175000001440000000000014211616226012723 5ustar acorlissusersParanoid-2.10/t/0000750000175000001440000000000014211616225013165 5ustar acorlissusersParanoid-2.10/t/32_log_file-lockstat.t0000644000175000001440000000473214162676517017312 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 13; use Paranoid; use Paranoid::Log; use Paranoid::Process qw(:pfork); use Paranoid::IO::Line; use Paranoid::Debug; use Paranoid::Module; use Fcntl qw(:DEFAULT :flock :mode :seek); psecureEnv(); $SIG{CHLD} = \&sigchld; my ( $child, $pid, @lines, $line, $i, $j ); my $file = './t/foo.log'; unlink $file if -f $file; # Load a bad facility ok( !startLogger( 'foo', 'File', PL_WARN, PL_EQ ), 'startLogger 1' ); ok( plog( PL_WARN, 'this is a test' ), 'plog 1' ); ok( stopLogger('foo'), 'stopLogger 1' ); ok( startLogger( 'foo', 'File', PL_WARN, PL_EQ, { file => $file, syslog => 1 } ), 'startLogger 2' ); ok( plog( PL_WARN, "this is a test" ), 'plog 2' ); SKIP: { skip( 'No Time::HiRes -- skipping permissions test', 1 ) unless loadModule( 'Time::HiRes', qw(usleep) ); # Fork some children and have them all log fifty messages each foreach $child ( 1 .. 5 ) { unless ( $pid = pfork() ) { for ( 1 .. 50 ) { my $intvl = int rand 500; usleep($intvl); plog( PL_WARN, "child $child: this is test #$_ (slept $intvl usec)" ); } exit 0; } } while ( childrenCount() ) { sleep 1 } sleep 5; # Count the number of lines -- should be 251 piolClose($file); slurp( $file, @lines, 1 ); my $rv = ( scalar @lines == 251 or scalar @lines == 252 ); warn "Number of lines: @{[ scalar @lines ]}\n"; ok( $rv, 'line count' ); #system("cp $file $file-inspect"); # Make sure children have been logging at the same time and not blocked # by advisory locks, etc. $i = $j = 0; while (@lines) { $line = shift @lines; if ( $line =~ /child 2:/s ) { $i++; $i += $j; $j = 0; } elsif ($i) { $j++; } } ok( $i > 55, 'multiple children logged' ); } ok( stopLogger('foo'), 'stopLogger 2' ); ok( startLogger( 'foo', 'File', PL_WARN, PL_GE, { file => $file, mode => O_TRUNC | O_RDWR, } ), 'logger options 1' ); my @fstats = stat $file; is( $fstats[7], 0, 'file size' ); ok( stopLogger('foo'), 'stopLogger 2' ); unlink $file; ok( startLogger( 'foo', 'File', PL_WARN, PL_GE, { file => $file, perm => 0600, mode => O_CREAT | O_RDWR, } ), 'logger options 2' ); @fstats = stat $file; is( $fstats[2] & 077777, 0600, 'file perm' ); unlink $file; Paranoid-2.10/t/04_input.t0000644000175000001440000001342312741127435015032 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 146; use Paranoid; use Paranoid::Input qw(:all); use Paranoid::Debug; use strict; use warnings; psecureEnv(); my ( $val, $fh, $f, $l, @lines, $rv, @all ); # Test detainting of valid data my @tests = ( [qw(100 number)], [qw(-0.5 number)], [qw(abc alphabetic)], [qw(abc123 alphanumeric)], [qw(THX1138 alphanumeric)], [qw(acorliss login)], [qw(foo@bar email)], [qw(foo.foo@bar.com email)], [qw(a-.-a"; nometa)], [qw(/foo/bar/.foo filename)], [qw(localhost hostname)], [qw(7x.com hostname)], [qw(foo.bar-roo.org hostname)], [qw(127.0.0.1 ipv4addr)], [qw(127.0.0.1/8 ipv4netaddr)], [qw(::1 ipv6addr)], [qw(::1/128 ipv6netaddr)], [qw(fe80::250:56ff:fec0:8/64 ipv6netaddr)], ); foreach (@tests) { ok( detaint( $$_[0], $$_[1], $val ), "detaint $$_[0] ($$_[1]) 1" ); is( $val, $$_[0], "$$_[0] ($$_[1]) match 1" ); } # Repeat test copying results to original scalar foreach (@tests) { $val = $$_[0]; ok( detaint( $val, $$_[1] ), "detaint $$_[0] ($$_[1]) 2" ); is( $val, $$_[0], "$$_[0] == $val ($$_[1]) $val match 2" ); } # Test detainting of invalid data @tests = ( [qw(100.00.1 number)], [qw(aDb97_ alphabetic)], [qw(abc-123 alphanumeric)], [qw(1foo login)], [qw(_34@bar.com email)], [qw('`! nometa)], [qw(/^/foo filename)], [qw(-foo.com hostname)], [qw(foo_bar.org hostname)], [qw(294.0.0.1 ipv4addr)], [qw(ge00:: ipv6addr)], [qw(127.0.0.1/48 ipv4netaddr)], [qw(fe80::/256 ipv6netaddr)], [qw(fe80::ac87:: ipv6netaddr)], ); foreach (@tests) { ok( !detaint( $$_[0], $$_[1], $val ), "detaint $$_[0] ($$_[1])" ); is( $val, undef, 'value is undef' ); } # Test detaint of arrays my @vals; @tests = qw(100 -0.5); ok( detaint( @tests, 'number', @vals ), 'detaint array 1' ); is( $vals[0], 100, 'detaint array 2' ); ok( detaint( @tests, 'number' ), 'detaint array 3' ); is( $tests[0], 100, 'detaint array 4' ); push @tests, 'localhost'; ok( !detaint( @tests, 'number', @vals ), 'detaint array 5' ); is( scalar(@vals), 3, 'detaint array 6' ); is( $vals[0], 100, 'detaint array 7' ); is( $vals[2], undef, 'detaint array 8' ); push @tests, 'localhost'; ok( !detaint( @tests, 'number' ), 'detaint array 9' ); is( scalar(@tests), 4, 'detaint array 10' ); is( $tests[0], 100, 'detaint array 11' ); is( $tests[3], undef, 'detaint array 12' ); # Test detaint of hashes my %vals; my %tests = ( one => 100, two => -0.5, ); ok( detaint( %tests, 'number', %vals ), 'detaint hash 1' ); is( $vals{one}, 100, 'detaint hash 2' ); ok( detaint( %tests, 'number' ), 'detaint hash 3' ); is( $tests{one}, 100, 'detaint hash 4' ); $tests{three} = 'localhost'; ok( !detaint( %tests, 'number', %vals ), 'detaint hash 5' ); is( scalar( keys %vals ), 3, 'detaint hash 6' ); is( $vals{one}, 100, 'detaint hash 7' ); is( $vals{three}, undef, 'detaint hash 8' ); $tests{four} = 'localhost'; ok( !detaint( %tests, 'number' ), 'detaint hash 9' ); is( scalar( keys %tests ), 4, 'detaint hash 10' ); is( $tests{one}, 100, 'detaint hash 11' ); is( $tests{three}, undef, 'detaint hash 12' ); is( $tests{four}, undef, 'detaint hash 13' ); # Test non-existent regex my $foo = "foo"; ok( !detaint( $foo, 'arg', $val ), 'detaint w/unknown regex' ); # Test regex ok( detaint( $foo, qr/.o*/si, $val ), 'detaint w/passed regex 1' ); is( $foo, $val, 'detaint w/passed regex 2' ); # Test custom regex $Paranoid::Input::regexes{tel} = qr/\d{3}-\d{4}/; $foo = '345-7211'; ok( detaint( $foo, 'tel', $val ), 'detaint 345-7211 tel' ); is( $val, '345-7211', 'strings match' ); # Test stringMatch my $long = << '__EOF__'; This is a semi-random string of gibberish that merely pretends to be a paragraph in search of a meaning. I only want to throw enough content at my poor, pitiful subroutine to verify that it actually works. It probably won't, though, and that's a damned shame. __EOF__ my @words1 = qw( /semi/ gibberish pitiful /ara/ ); my @words2 = qw( /exa/ /on.f/ ); ok( stringMatch( $long, @words1 ), 'stringMatch (good test)' ); ok( !stringMatch( $long, @words2 ), 'stringMatch (bad test)' ); # Test pchomp @lines = ( "This was authored on UNIX.\12", "This was authored on Mac.\15", "This was authored on PC.\15\12", "This was authored in my head.", ); # First, scalar tests my $counter = 0; foreach (@lines) { $l = $_; $counter++; ($val) = ( $l =~ /^(.+\.)/ ); pchomp($l); is( $val, $l, "pchomp scalar $counter" ); } # Test arrrays $val = length join '', @lines; ok( pchomp(@lines), 'pchomp array 1' ); is( $val - 4, length( join '', @lines ), 'pchomp array 2' ); # Test hashes my %hash = ( one => "This was authored on UNIX.\12", two => "This was authored on Mac.\15", three => "This was authored on PC.\15\12", four => "This was authored in my head.", ); ok( pchomp(%hash), 'pchomp hash 1' ); is( $val - 4, length( join '', values %hash ), 'pchomp hash 2' ); # Test builtin vars $_ = "hello!\n"; ok( pchomp(), 'pchomp $_ 1' ); is( length($_), length('hello!'), 'pchomp $_ 2' ); # Test chomp fall-through { local $/; $/ = ':'; my $out = "This was authored on UNIX.\12"; $rv = pchomp($out); ok( $rv == 0, "pchomp fall-through 1" ); $/ = undef; $rv = pchomp($out); ok( $rv == 0, "pchomp fall-through 2" ); $/ = 30; $rv = pchomp($out); ok( $rv == 0, "pchomp fall-through 3" ); $/ = ".\12"; $rv = pchomp($out); ok( $rv == 2, "pchomp fall-through 4" ); } Paranoid-2.10/t/43_network.t0000644000175000001440000001077512752511357015400 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 34; use Paranoid; use Paranoid::Network; use Paranoid::Module; use Paranoid::Debug; use Socket; #PDEBUG = 20; use strict; use warnings; psecureEnv(); my $sendmail = '... [IPv6:1111:2222:3333:4444:5555:6666:7777:8888] did not issue MAIL/EXPN/VRFY/ETRN during connection ...'; my $ifconfig = << '__EOF__'; lo Link encap:Local Loopback inet addr:127.0.0.1 Mask:255.0.0.0 inet6 addr: ::1/128 Scope:Host UP LOOPBACK RUNNING MTU:16436 Metric:1 RX packets:199412 errors:0 dropped:0 overruns:0 frame:0 TX packets:199412 errors:0 dropped:0 overruns:0 carrier:0 collisions:0 txqueuelen:0 RX bytes:90311250 (86.1 MiB) TX bytes:90311250 (86.1 MiB) __EOF__ my $iproute = << '__EOF__'; 1: lo: mtu 16436 qdisc noqueue state UNKNOWN link/loopback 00:00:00:00:00:00 brd 00:00:00:00:00:00 inet 127.0.0.1/8 brd 127.255.255.255 scope host lo inet6 ::1/128 scope host valid_lft forever preferred_lft forever 2: eth0: mtu 1500 qdisc pfifo_fast state DOWN qlen 1000 link/ether 00:d0:f9:6a:cd:d0 brd ff:ff:ff:ff:ff:ff 3: wlan0: mtu 1500 qdisc pfifo_fast state UP qlen 1000 link/ether 00:12:a8:ff:0e:a1 brd ff:ff:ff:ff:ff:ff inet 192.168.2.156/24 brd 192.168.2.255 scope global wlan0 inet6 fe80::212:a8ff:feff:0ea1/64 scope link valid_lft forever preferred_lft forever __EOF__ ok( ipInNetworks( '127.0.0.1', '127.0.0.0/8' ), 'ipInNetworks 1' ); ok( ipInNetworks( '127.0.0.1', '127.0.0.0/255.0.0.0' ), 'ipInNetworks 2' ); ok( ipInNetworks( '127.0.0.1', '127.0.0.1' ), 'ipInNetworks 3' ); ok( !eval "ipInNetworks('127.0.s.1', '127.0.0.1')", 'ipInNetworks 4' ); ok( ipInNetworks( '127.0.0.1', '192.168.0.0/24', '127.0.0.0/8' ), 'ipInNetworks 5' ); ok( !ipInNetworks( '127.0.0.1', qw(foo bar roo) ), 'ipInNetworks 6' ); ok( hostInDomains( 'foo.bar.com', 'bar.com' ), 'hostInDomains 1' ); ok( hostInDomains( 'localhost', 'localhost' ), 'hostInDomains 2' ); ok( !eval "hostInDomains('localh!?`ls`ost', 'localhost')", 'hostInDomains 3' ); ok( !hostInDomains( 'localhost', 'local?#$host' ), 'hostInDomains 4' ); ok( hostInDomains( 'foo-77.bar99.net', 'dist-22.mgmt.bar-bar.com', 'bar99.net' ), 'hostInDomains 5' ); is( scalar( grep !/:/, extractIPs($ifconfig) ), 2, 'extractIPs 1' ); is( scalar( grep !/:/, extractIPs($iproute) ), 4, 'extractIPs 2' ); is( scalar( grep !/:/, extractIPs( $ifconfig, $iproute ) ), 6, 'extractIPs 3' ); is( scalar( grep { $_ eq "192.168.2.255" } extractIPs($iproute) ), 1, 'extractIPs 4' ); is( netIntersect(qw(192.168.0.0/24 192.168.0.128/25)), 1, 'netIntersect 1' ); is( netIntersect(qw(192.168.0.128/25 192.168.0.128/24)), -1, 'netIntersect 2' ); is( netIntersect(qw(192.168.0.0/24 foo)), 0, 'netIntersect 3' ); SKIP: { skip( 'Missing IPv6 support -- skipping IPv6 tests', 16 ) unless $] >= 5.012 or loadModule('Socket6'); ok( ipInNetworks( '::1', '::1' ), 'ipInNetworks 7' ); ok( !ipInNetworks( '::1', '127.0.0.1/8' ), 'ipInNetworks 8' ); ok( ipInNetworks( '::ffff:192.168.0.5', '192.168.0.0/24' ), 'ipInNetworks 9' ); ok( !ipInNetworks( '::ffff:192.168.0.5', '::ffff:192.168.0.0/104' ), 'ipInNetworks 9' ); ok( ipInNetworks( 'fe80::212:e9dd:fed9:a1f9', 'fe80::/64' ), 'ipInNetworks 10' ); ok( !ipInNetworks( 'fe80::212:e9dd:fed9:a1f9', 'fe81::/64' ), 'ipInNetworks 11' ); ok( ipInNetworks( 'fe80::212:e9dd:fed9:a1f9', 'fe80::/60' ), 'ipInNetworks 12' ); ok( ipInNetworks( 'fe80::ffff:212:e9dd:fed9:a1f9', 'fe80:0:0:ffff::/60' ), 'ipInNetworks 13' ); ok( ipInNetworks( '::1', 'fe80:0:0:ffff::/60', '::ffff:192.168.0.0/104', '192.168.0.0/24', '::1' ), 'ipInNetworks ipv6 1' ); is( scalar( grep /^1111:/, extractIPs($sendmail) ), 1, 'extractIPs 5' ); ok( scalar extractIPs($ifconfig) == 3, 'extractIPs 6' ); ok( scalar extractIPs($iproute) == 6, 'extractIPs 7' ); ok( scalar extractIPs( $ifconfig, $iproute ) == 9, 'extractIPs 8' ); is( netIntersect(qw(fe80::212:e9dd:fed9:a1f9 fe80::/64)), -1, 'netIntersect ipv6 1' ); is( netIntersect( qw(fe80::/64 fe80::212:e9dd:fed9:a1f9) ), 1, 'netIntersect ipv6 2' ); is( netIntersect(qw(bar foo)), 0, 'netIntersect ipv6 3' ); } Paranoid-2.10/t/21_filesystem_preadDir.t0000644000175000001440000000336212741127435017671 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 18; use Paranoid; use Paranoid::Debug; use Paranoid::Filesystem; #PDEBUG = 20; psecureEnv(); use strict; use warnings; no warnings qw(qw); my @tmp; sub touch { my $filename = shift; my $size = shift || 0; my $fh; open $fh, '>', $filename or die "Couldn't touch file $filename: $!\n"; while ( $size - 80 > 0 ) { print $fh 'A' x 79, "\n"; $size -= 80; } print $fh 'A' x $size; close $fh; } sub prep { mkdir './t/test_fs', 0777; mkdir './t/test_fs/subdir', 0777; mkdir './t/test_fs/subdir2', 0777; touch('t/test_fs/one'); touch('t/test_fs/two'); touch('t/test_fs/subdir/three'); } # start testing prep(); ok( preadDir( './t/test_fs', @tmp ), 'preadDir 1' ); is( $#tmp, 3,, 'preadDir 2' ); ok( !preadDir( './t/test_fsss', @tmp ), 'preadDir 3' ); is( $#tmp, -1,, 'preadDir 4' ); ok( !preadDir( './t/test_fs/one', @tmp ), 'preadDir 5' ); ok( Paranoid::ERROR =~ /is not a dir/, 'preadDir 6' ); ok( psubdirs( './t/test_fs', @tmp ), 'psubdirs 1' ); is( $#tmp, 1,, 'psubdirs 2' ); ok( psubdirs( './t/test_fs/subdir', @tmp ), 'psubdirs 3' ); is( $#tmp, -1,, 'psubdirs 4' ); ok( !psubdirs( './t/test_fs/ssubdir', @tmp ), 'psubdirs 5' ); is( $#tmp, -1,, 'psubdirs 6' ); ok( pfiles( './t/test_fs', @tmp ), 'pfiles 1' ); is( $#tmp, 1,, 'pfiles 2' ); ok( !pfiles( './t/test_fss', @tmp ), 'pfiles 3' ); is( $#tmp, -1,, 'pfiles 4' ); ok( pfiles( './t/test_fs/subdir2', @tmp ), 'pfiles 5' ); is( $#tmp, -1,, 'pfiles 6' ); # Clean up files unlink qw(t/test_fs/one t/test_fs/two t/test_fs/subdir/three); rmdir './t/test_fs/subdir' || warn "subdir: $!\n"; rmdir './t/test_fs/subdir2' || warn "subdir2: $!\n"; rmdir './t/test_fs' || warn "test_fs: $!\n"; Paranoid-2.10/t/05_data.t0000644000175000001440000000664112741127435014611 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 30; use Paranoid; use Paranoid::Debug; use Paranoid::Data; use Socket; use strict; use warnings; psecureEnv(); my $sScalar = 'foo'; my @sArray = qw( one two three four); my %sHash = ( a => 'A Value', b => 'B Value', c => 'C Value', ); my ( $tScalar, @tArray, %tHash, $rv ); # Simple one-level copies $rv = deepCopy( $sScalar, $tScalar ); is( $rv, 1, 'deepCopy scalar ref 1' ); is( $tScalar, 'foo', 'deepCopy scalar ref 2' ); $rv = deepCopy( @sArray, @tArray ); is( $rv, 4, 'deepCopy array ref 1' ); is( $tArray[2], 'three', 'deepCopy array ref 2' ); $rv = deepCopy( %sHash, %tHash ); is( $rv, 3, 'deepCopy hash ref 1' ); is( $tHash{c}, 'C Value', 'deepCopy hash ref 2' ); # Simple two-level copies @sArray = ( qw( one two ), [qw( subone subtwo subtree )], qw( three four ), ); %sHash = ( a => 'A Value', b => { Key => 'b', Value => 'Hash Ref', }, c => 'C Value', ); $rv = deepCopy( @sArray, @tArray ); is( $rv, 8, 'deepCopy array ref 3' ); is( $tArray[2][1], 'subtwo', 'deepCopy array ref 4' ); $rv = deepCopy( %sHash, %tHash ); is( $rv, 5, 'deepCopy hash ref 3' ); is( $tHash{b}{Value}, 'Hash Ref', 'deepCopy hash ref 4' ); # More complex structures $sHash{d} = { Key => 'd', Value => [@sArray], }; $sArray[3] = $sHash{b}; $rv = deepCopy( @sArray, @tArray ); is( $rv, 10, 'deepCopy array ref 5' ); is( $tArray[3]{Key}, 'b', 'deepCopy array ref 6' ); $rv = deepCopy( %sHash, %tHash ); is( $rv, 16, 'deepCopy hash ref 5' ); is( $tHash{d}{Value}[2][1], 'subtwo', 'deepCopy hash ref 6' ); # Expected failures ok( !eval 'deepCopy(\%sHash, \@tArray)', 'deepCopy fail 1' ); $sArray[2][3] = $sHash{d}; $rv = deepCopy( @sArray, @tArray ); is( $rv, 0, 'deepCopy fail 3' ); @sArray = @tArray = (); ok( deepCmp( @sArray, @tArray ), 'deepCmp array 1' ); @sArray = @tArray = ( qw(one two three four), undef, qw(six) ); ok( deepCmp( @sArray, @tArray ), 'deepCmp array 2' ); $tArray[4] = 'five'; ok( !deepCmp( @sArray, @tArray ), 'deepCmp array 3' ); $sArray[2] = 3; ok( !deepCmp( @sArray, @tArray ), 'deepCmp array 4' ); $tArray[4] = undef; $sArray[2] = 'three'; $sArray[6] = [qw(foo bar)]; $tArray[6] = [qw(foo bar)]; ok( deepCmp( @sArray, @tArray ), 'deepCmp array 5' ); $sArray[6][1] = 'roo'; ok( !deepCmp( @sArray, @tArray ), 'deepCmp array 6' ); $sArray[6] = $tArray[6]; ok( deepCmp( @sArray, @tArray ), 'deepCmp array 7' ); $sArray[6] = ''; ok( !deepCmp( @sArray, @tArray ), 'deepCmp array 8' ); $sArray[6] = { one => 'two', three => 'four' }; ok( !deepCmp( @sArray, @tArray ), 'deepCmp array 9' ); $tArray[6] = { one => 'two', three => 'four' }; ok( deepCmp( @sArray, @tArray ), 'deepCmp array 10' ); #PDEBUG = 20; %sHash = ( one => 1, two => [qw(foo bar)], three => { foo => 'bar', bar => 'roo', }, four => undef, ); %tHash = ( one => 1, two => [qw(foo bar)], three => { foo => 'bar', bar => 'roo', }, four => undef, ); ok( deepCmp( %sHash, %tHash ), 'deepCmp hash 1' ); $tHash{three}{help} = 'me'; ok( !deepCmp( %sHash, %tHash ), 'deepCmp hash 2' ); $sHash{three}{test} = {%tHash}; deepCopy( %sHash, %tHash ); ok( deepCmp( %sHash, %tHash ), 'deepCmp hash 3' ); $tHash{three}{test}{three}{foo} = undef; ok( !deepCmp( %sHash, %tHash ), 'deepCmp hash 4' ); Paranoid-2.10/t/06_module.t0000644000175000001440000000127012741127435015157 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 9; use Paranoid; use Paranoid::Module; use Paranoid::Debug; #PDEBUG = 20; use strict; use warnings; no warnings 'once'; psecureEnv(); ok( loadModule("Paranoid::Input"), 'loadModule 1' ); ok( !loadModule("Paranoid::InputAAAAAAAA"), 'loadModule 2' ); ok( loadModule( 'Socket', 'inet_aton' ), 'loadSocket 1' ); ok( !defined *main::inet_ntoa{CODE}, 'loadSocket 2' ); ok( loadModule( 'Socket', 'inet_ntoa' ), 'loadSocket 3' ); ok( defined *main::inet_ntoa{CODE}, 'loadSocket 4' ); ok( loadModule( 'File::Path', '!mkpath' ), 'loadFile 1' ); ok( !defined *main::mkpath{CODE}, 'loadFile 2' ); ok( defined *main::rmtree{CODE}, 'loadFile 3' ); Paranoid-2.10/t/30_log.t0000644000175000001440000000135512741127435014454 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 9; use Paranoid; use Paranoid::Log; use Paranoid::Debug; psecureEnv(); # Redirect STDERR to /dev/null close STDERR; open STDERR, '>', '/dev/null'; # Load a non-existent facility ok( !startLogger( 'foo', 'stderrrrrrrrrrrrr', PL_WARN, PL_GE ), 'startLogger 1' ); ok( startLogger( 'foo', 'Stderr', PL_WARN, PL_GE ), 'startLogger 2' ); ok( plog( PL_CRIT, 'this is a test' ), 'plog 1a' ); ok( plog( PL_DEBUG, 'this is a test, too' ), 'plog 1b' ); ok( stopLogger('foo'), 'stopLogger 1' ); ok( plog( PL_CRIT, "this is a test" ), 'plog 2' ); ok( plog( PL_EMERG, "this is a test" ), 'plog 3' ); ok( plog( PL_ALERT, "this is a test" ), 'plog 4' ); ok( plog( PL_WARN, "this is a test" ), 'plog 5' ); Paranoid-2.10/t/33_log_pdebug.t0000644000175000001440000000157013424312544016000 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 5; use Paranoid; use Paranoid::Log; use Paranoid::Debug qw(:all); use strict; use warnings; psecureEnv(); my @msgs; ok( startLogger( 'pdebug', 'PDebug' ), 'startLogger 1' ); ok( startLogger( 'buffer', 'Buffer', PL_WARN, PL_NE, { size => 30 } ), 'startLogger 2' ); for my $n ( 1 .. 10 ) { plog( PL_DEBUG, "test number $n" ); } @msgs = Paranoid::Log::Buffer::dumpBuffer('buffer'); is( $msgs[9][1], 'test number 10', 'check message 1' ); for my $n ( 1 .. 10 ) { plog( PL_DEBUG, 'sprintf test number %s', $n ); } @msgs = Paranoid::Log::Buffer::dumpBuffer('buffer'); is( $msgs[19][1], 'sprintf test number 10', 'check message 2' ); for my $n ( 1 .. 10 ) { plog( PL_DEBUG, 'no sprintf test number %s' ); } @msgs = Paranoid::Log::Buffer::dumpBuffer('buffer'); is( $msgs[29][1], 'no sprintf test number %s', 'check message 3' ); Paranoid-2.10/t/01_init_core.t0000644000175000001440000000321314173470654015644 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 22; use strict; use warnings; ok( eval 'require Paranoid;', 'Loaded Paranoid' ); ok( eval 'require Paranoid::Args;', 'Loaded Paranoid::Args' ); ok( eval 'require Paranoid::Data;', 'Loaded Paranoid::Data' ); ok( eval 'require Paranoid::Debug;', 'Loaded Paranoid::Debug' ); ok( eval 'require Paranoid::Filesystem;', 'Loaded Paranoid::Filesystem' ); ok( eval 'require Paranoid::IO;', 'Loaded Paranoid::IO' ); ok( eval 'require Paranoid::IO::Line;', 'Loaded Paranoid::IO::Line' ); ok( eval 'require Paranoid::IO::Lockfile;', 'Loaded Paranoid::IO::Lockfile' ); ok( eval 'require Paranoid::Input;', 'Loaded Paranoid::Input' ); ok( eval 'require Paranoid::Log;', 'Loaded Paranoid::Lockfile' ); ok( eval 'require Paranoid::Log::Buffer;', 'Loaded Paranoid::Log::Buffer' ); ok( eval 'require Paranoid::Log::File;', 'Loaded Paranoid::Log::File' ); ok( eval 'require Paranoid::Module;', 'Loaded Paranoid::Module' ); ok( eval 'require Paranoid::Network;', 'Loaded Paranoid::Network' ); ok( eval 'require Paranoid::Network::IPv4;', 'Loaded Paranoid::Network::IPv4' ); ok( eval 'require Paranoid::Network::IPv6;', 'Loaded Paranoid::Network::IPv6' ); ok( eval 'require Paranoid::Network::Socket;', 'Loaded Paranoid::Network::Socket' ); ok( eval 'require Paranoid::Process;', 'Loaded Paranoid::Process' ); eval 'Paranoid->import;'; ok( psecureEnv('/bin:/sbin'), 'psecureEnv 1' ); is( $ENV{PATH}, '/bin:/sbin', 'Validated PATH' ); ok( psecureEnv(), 'psecureEnv 2' ); is( $ENV{PATH}, '/bin:/sbin:/usr/bin:/usr/sbin', 'Validated PATH' ); Paranoid-2.10/t/98_pod_coverage.t0000644000175000001440000000041312741127435016340 0ustar acorlissusers#!/usr/bin/perl -T use Paranoid; use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok( { private => [ qr/^_/, qr/^[DI]LEVEL$/, qr/^PDINDIGNORED$/ ] } ); Paranoid-2.10/t/10_io_line.t0000644000175000001440000001061512741127435015306 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 47; use Paranoid; use Paranoid::IO qw(:all); use Paranoid::IO::Line qw(:all); use Paranoid::Debug; use Fcntl qw(:DEFAULT :mode :seek :flock); use strict; use warnings; psecureEnv(); my ( $val, $fh, $f, $l, @lines, $rv, @all ); # Create another test file for sip PIOMAXFSIZE = 4096; PIOBLKSIZE = 512; $l = "1" x 78 . "\15\12"; $val = int( ( 6 * 1024 ) / length $l ); $f = "./t/test24KB"; open $fh, '>', $f or die "failed to open file: $!\n"; for ( 1 .. $val ) { print $fh $l } for ( 1 .. $val ) { print $fh '0' x 80 } for ( 1 .. $val ) { print $fh $l } for ( 1 .. $val ) { print $fh '0' x 80 } close $fh; # Sip block 1 is( sip( $f, @lines ), 51, 'sip block 1 - 1' ); is( $lines[0], $l, 'sip block 1 - 2' ); push @all, @lines; # Sip block 2 is( sip( $f, @lines ), undef, 'sip block 2 - 1' ); push @all, @lines; is( scalar @lines, 25, 'sip block 2 - 2' ); # Sip block 3 is( sip( $f, @lines ), '0 but true', 'sip block 3 - 1' ); push @all, @lines; is( scalar @lines, 0, 'sip block 3 - 2' ); # Sip block 4 is( sip( $f, @lines ), 51, 'sip block 4 - 1' ); push @all, @lines; # Sip block 5 is( sip( $f, @lines ), undef, 'sip block 5 - 1' ); push @all, @lines; is( scalar @lines, 24, 'sip block 5 - 2' ); # Sip block 6 is( sip( $f, @lines ), undef, 'sip block 6 - 1' ); push @all, @lines; is( scalar @lines, 0, 'sip block 6 - 2' ); # Sip block 7 is( sip( $f, @lines ), '0 but true', 'sip block 7 - 1' ); push @all, @lines; is( scalar @lines, 0, 'sip block 7 - 2' ); # Add some content, try sipping some more content open $fh, '>>', $f or die "failed to open file: $!\n"; for ( 1 .. $val ) { print $fh "2" x 78 . "\12" } close $fh; # Sip block 8 (with autochomp) is( sip( $f, @lines, 1 ), 50, 'sip block 8 - 1' ); push @all, @lines; # Test no chomp/chomp is( length $all[0], 80, 'sip no pchomp 1' ); is( length $all[-1], 78, 'sip pchomp 1' ); is( $all[-1], '2' x 78, 'sip pchomp 2' ); # Sip block 9 & 10 is( sip( $f, @lines, 1 ), 25, 'sip block 9 - 1' ); is( sip( $f, @lines, 1 ), '0 but true', 'sip block 10 - 1' ); # Tailf and piolClose ok( piolClose($f), 'piolClose 1' ); is( tailf( $f, @lines, 0 ), 10, 'tailf 1' ); ok( piolClose($f), 'piolClose 2' ); is( tailf( $f, @lines, 0, -75 ), 75, 'tailf 2' ); ok( piolClose($f), 'piolClose 3' ); # Multiplea tail test ok( popen( $f, O_RDWR ), 'multiple tailf 1' ); is( tailf( $f, @lines, 0, -1 ), 1, 'multiple tailf 2' ); is( tailf( $f, @lines, 0, -1 ), '0 but true', 'multiple tailf 3' ); ok( pappend( $f, "line 1\n,line 2\nline 3" ), 'multiple tailf 4' ); is( tailf( $f, @lines, 0, -1 ), 2, 'multiple tailf 5' ); ok( pappend( $f, "\n" ), 'multiple tailf 6' ); is( tailf( $f, @lines, 0, -1 ), 1, 'multiple tailf 7' ); is( $lines[0], "line 3\n", 'multiple tailf 8' ); # Test truncate open $fh, '>', $f or die "failed to open file: $!\n"; print $fh "line a\nline b\nline c\n"; close $fh; is( tailf( $f, @lines, 0, -4 ), 3, 'multiple tailf 11' ); is( $lines[0], "line a\n", 'multiple tailf 12' ); # Test overwrite unlink $f; open $fh, '>', $f or die "failed to open file: $!\n"; print $fh "testing\ntesting\n"; close $fh; is( tailf( $f, @lines, 0, -4 ), 2, 'multiple tailf 13' ); is( $lines[0], "testing\n", 'multiple tailf 14' ); is( $lines[1], "testing\n", 'multiple tailf 15' ); # Test delete unlink $f; is( tailf( $f, @lines, 0, -4 ), undef, 'multiple tailf 16' ); # Test slurp # # Create a test file PIOMAXFSIZE = 16 * 1024; $val = int( ( 4 * 1024 ) / length $l ); $f = "./t/test4KB"; open $fh, '>', $f or die "failed to open file: $!\n"; for ( 1 .. $val ) { print $fh $l } close $fh; # Test small file ok( slurp( $f, @lines ), 'slurp w/4KB file 1' ); ok( @lines == $val, 'slurp w/4KB file 2' ); # Test filehandle slurp open $fh, '<', $f or die "failed to open file: $!\n"; ok( slurp( $fh, @lines ), 'slurp w/filehandle 1' ); ok( @lines == $val, 'slurp w/filehandle 2' ); ok( !slurp( $fh, @lines ), 'slurp w/filehandle 3' ); ok( @lines == 0, 'slurp w/filehandle 4' ); close $fh; # Create a larger test file $val = int( ( 24 * 1024 ) / length $l ); $f = "./t/test24KB"; open $fh, '>', $f or die "failed to open file: $!\n"; for ( 1 .. $val ) { print $fh $l } close $fh; # Test a larger file ok( !slurp( $f, @lines ), 'slurp w/24KB file 1' ); ok( scalar @lines, 'slurp w/24KB file 2' ); # Test reading non-existant file $f = "./t/foo-test"; ok( !slurp( $f, @lines ), 'slurp\'ing non-existent file' ); unlink qw(./t/test4KB ./t/test24KB); Paranoid-2.10/t/99_pod.t0000644000175000001440000000033312741127435014467 0ustar acorlissusers#!/usr/bin/perl -T use Paranoid; use Test::More; psecureEnv('/bin:/usr/bin:/usr/ccs/bin:/usr/local/bin'); eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Paranoid-2.10/t/50_process.t0000644000175000001440000001271513661362651015360 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 39; use Paranoid; use Paranoid::Process qw(:all); use Paranoid::IO qw(:all); use Paranoid::IO::Line; use Paranoid::Debug; use strict; use warnings; psecureEnv(); PIOMAXFSIZE = 512 * 1024; my ( $rv, $id, @tmp, $i, $pid ); my ( @passwd, $user1, $user2, $uid1, $uid2 ); my ( @group, $group1, $group2, $gid1, $gid2 ); SKIP: { # Prep: get two valid users & groups to test with # # NOTE: we use user1/group1 to test translation functions (they # will probably be root/root|wheel) and user2/group2 to test # user switch functions (they will hopefully be unprivileged # users) slurp( '/etc/passwd', @passwd, 1 ); slurp( '/etc/group', @group, 1 ); # Prune any comment lines (&*^@#4 FreeBSD!?) @passwd = grep !/^\s*(?:#.*)?$/, @passwd; @group = grep !/^\s*(?:#.*)?$/, @group; if ( @passwd > 1 ) { ( $user1, $uid1 ) = ( split( /:/, $passwd[0] ) )[ 0, 2 ]; ( $user2, $uid2 ) = ( split( /:/, $passwd[$#passwd] ) )[ 0, 2 ]; $uid1 = undef unless $uid1 =~ /^\d+$/; $uid2 = undef unless $uid2 =~ /^\d+$/; } if (@group) { ( $group1, $gid1 ) = ( split( /:/, $group[0] ) )[ 0, 2 ]; ( $group2, $gid2 ) = ( split( /:/, $group[$#group] ) )[ 0, 2 ]; $gid1 = undef unless $gid1 =~ /^\d+$/; $gid2 = undef unless $gid2 =~ /^\d+$/; } skip( "Couldn't find enough users/groups to test with", 7 ) unless defined $uid1 and defined $uid2 and defined $gid1 and defined $gid2; $id = ptranslateUser($user1); if ( $id == -2 ) { warn 'Perl bug in casting unsigned int as signed int found -- ' . "ignoring\n"; $id = $uid1; } is( $id, $uid1, "ptranslateUser 1 ($user1)" ); $id = ptranslateUser('no freaking way:::!'); is( $id, undef, 'ptranslateUser 2' ); $id = ptranslateGroup($group1); if ( $id == -2 ) { warn 'Perl bug in casting unsigned int as signed int found -- ' . "ignoring\n"; $id = $gid1; } is( $id, $gid1, "ptranslateGroup 1 ($group1)" ); $id = ptranslateGroup('no freaking way:::!'); is( $id, undef, 'ptranslateGroup 2' ); skip( "Can't test switchUser without root privileges", 3 ) unless $< == 0; if ( $pid = fork ) { waitpid $pid, 0; $rv = !( $? >> 8 ); } else { $rv = switchUser($user2); exit !$rv; } is( $rv, 1, "switchUser 1 (from user $ENV{USER} to $user2)" ); if ( $pid = fork ) { waitpid $pid, 0; $rv = !( $? >> 8 ); } else { $rv = switchUser( undef, $group2 ); exit !$rv; } is( $rv, 1, "switchUser 2 (to group $group2)" ); if ( $pid = fork ) { waitpid $pid, 0; $rv = !( $? >> 8 ); } else { $rv = switchUser( $user2, $group2 ); exit !$rv; } is( $rv, 1, 'switchUser 3 (user & group)' ); } my $sigpid = 0; # Install our signal handler $SIG{CHLD} = \&sigchld; # Test pfork child counting foreach ( 1 .. 5 ) { if ( pfork() == 0 ) { sleep 5; exit 0; } else { ok( 1, "pfork $_" ); } } $rv = childrenCount(); is( $rv, 5, 'childrenCount 1' ); # Wait for all children to exit while ( childrenCount() ) { sleep 1 } # Test pfork w/MAXCHILDREN limit MAXCHILDREN = 3; foreach ( 1 .. 5 ) { if ( pfork() == 0 ) { sleep 5; exit 0; } else { ok( 1, "pfork @{[ $_ + 5 ]}" ); } } $rv = childrenCount() <= 3 ? 1 : 0; is( $rv, 1, 'childrenCount 2' ); # Wait for all children to exit while ( childrenCount() ) { sleep 1 } # Test installChldHandler sub testHandler ($$) { my $cpid = shift; my $cexit = shift; $sigpid = $cpid; } ok( installChldHandler(&testHandler), 'installChldHandler 1' ); MAXCHILDREN = 5; for ( 1 .. 5 ) { if ( pfork() == 0 ) { sleep 1; exit 0; } else { ok( 1, "pfork @{[ $_ + 10 ]}" ); } } while ( childrenCount() ) { sleep 1 } $rv = $sigpid ? 1 : 0; is( $rv, 1, 'SIGCHLD 1' ); # Test pcommFork my ( $rh, $wh, $response ); $rv = pcommFork( $rh, $wh ); if ( defined $rv ) { if ($rv) { ok( defined $rv, 'pcommFork 1' ); print $wh "Hello, child\n"; $response = <$rh>; is( $response, "Hello, parent\n", 'pcommFork 2' ); print $wh "Goodbye, child\n"; $response = <$rh>; is( $response, "Goodbye, parent\n", 'pcommFork 3' ); } else { $response = <$rh>; print $wh "Hello, parent\n"; $response = <$rh>; print $wh "Goodbye, parent\n"; sleep 1; exit 0; } } else { ok( defined $rv, 'pcommFork failed 1' ); ok( defined $rv, 'pcommFork failed 2' ); ok( defined $rv, 'pcommFork failed 3' ); } my ( $crv, $out ); # Test pcapture ok( pcapture( "echo foo", $crv, $out ), 'pcapture 1' ); chomp $out; is( $out, 'foo', 'pcapture 2' ); is( $crv, 0, 'pcapture 3' ); ok( !pcapture( "echo bar ; exit 3", $crv, $out ), 'pcapture 4' ); chomp $out; is( $out, 'bar', 'pcapture 5' ); is( $crv, 3, 'pcapture 6' ); ok( !pcapture( "echo roo ; exit 1", $crv, $out ), 'pcapture 7' ); chomp $out; is( $out, 'roo', 'pcapture 8' ); is( $crv, 1, 'pcapture 9' ); $rv = pcapture( "ecccchhhooooo", $crv, $out ); if ( $^O eq 'solaris' ) { warn "Solaris seems to only return '0', not '-1' for " . "non-existant commands.\n"; $rv = -1; } is( $rv, -1, 'pcapture 10' ); # TODO: have pcapture run command that kills itself, and reap RV Paranoid-2.10/t/25_filesystem_pchmod.t0000644000175000001440000000443713375541224017421 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 20; use Paranoid; use Paranoid::Debug; use Paranoid::Filesystem qw(:all); use Paranoid::Glob; #PDEBUG = 20; psecureEnv(); use strict; use warnings; no warnings qw(qw); my ( $rv, @stat, %errors ); # Test pchmod & family my %data = ( 'ug+rwx' => 0770, 'u+rwxs' => 04700, 'ugo+rwxt' => 01777, ); foreach ( keys %data ) { $rv = ptranslatePerms($_); is( $rv, $data{$_}, "perms match ($_)" ); } foreach ( '', qw(0990 xr+uG) ) { $rv = ptranslatePerms($_); is( $rv, undef, "perms undef ($_)" ); } $rv = ptranslatePerms('04755'); is( $rv, 04755, 'perms octal string' ); mkdir './t/test_chmod'; system('touch ./t/test_chmod/foo ./t/test_chmod/bar'); ok( pchmod( Paranoid::Glob->new( globs => [ qw(./t/test_chmod/foo ./t/test_chmod/bar) ] ), 'o+rwx', %errors ), 'pchmod 1' ); @stat = stat('./t/test_chmod/foo'); $rv = $stat[2] & 0007; is( $rv, 0007, 'pchmod 2' ); ok( !pchmod( Paranoid::Glob->new( globs => [ qw(./t/test_chmod/foo ./t/test_chmod/bar ./t/test_chmod/roo) ] ), 'o+rwx', %errors ), 'pchmod 3' ); ok( pchmod( './t/test_chmod/*', 0700 ), 'pchmod 4' ); ok( !pchmod( './t/test_chmod/roooo', 0755, %errors ), 'pchmod 5' ); mkdir './t/test_chmod2'; mkdir './t/test_chmod2/foo'; mkdir './t/test_chmod2/roo'; chmod 0777, qw(./t/test_chmod2 ./t/test_chmod2/foo ./t/test_chmod2/roo); symlink '../../test_chmod', './t/test_chmod2/foo/bar'; ok( pchmodR( './t/test_chmod2/*', 0750, 0, %errors ), 'pchmodR 1' ); @stat = stat('./t/test_chmod/foo'); $rv = $stat[2] & 07777; is( $rv, 0700, 'pchmodR 2' ); @stat = stat('./t/test_chmod2/foo'); $rv = $stat[2] & 07777; is( $rv, 0750, 'pchmodR 3' ); ok( pchmodR( './t/test_chmod2/*', 'o+rx' ), 'pchmodR 4' ); @stat = stat('./t/test_chmod2/foo'); $rv = $stat[2] & 07777; is( $rv, 0755, 'pchmodR 5' ); ok( pchmodR( './t/test_chmod2/*', 0755, 1 ), 'pchmodR 6' ); @stat = stat('./t/test_chmod/foo'); $rv = $stat[2] & 07777; is( $rv, 0755, 'pchmodR 7' ); ok( !pchmodR( './t/test_chmod2/roooo', 0755, 1, %errors ), 'pchmodR 7' ); system('rm -rf ./t/test_chmod* 2>/dev/null'); Paranoid-2.10/t/26_filesystem_pchown.t0000644000175000001440000000524013322662205017432 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 15; use Paranoid; use Paranoid::Debug; use Paranoid::Filesystem qw(:all); use Paranoid::Glob; use Paranoid::Process qw(ptranslateUser ptranslateGroup); #PDEBUG = 20; psecureEnv(); use strict; use warnings; no warnings qw(qw); sub touch { my $filename = shift; my $size = shift || 0; my $fh; open $fh, '>', $filename or die "Couldn't touch file $filename: $!\n"; while ( $size - 80 > 0 ) { print $fh 'A' x 79, "\n"; $size -= 80; } print $fh 'A' x $size; close $fh; } my ( $user, $group, $uid, $gid, $id, %errors ); mkdir './t/test_chown'; mkdir './t/test_chown2'; mkdir './t/test_chown2/foo'; symlink '../../test_chown', './t/test_chown2/foo/bar'; touch('./t/test_chown/foo'); touch('./t/test_chown/bar'); $user = 'nobody'; $uid = ptranslateUser($user); $group = 'nobody'; $gid = ptranslateGroup($group); my $hasNG = defined $gid; # NOTE: The following block is skipped due to a bug in all current # version of Perl involving platforms with unsigned ints for GIDs. A patch # has been submitted to bleadperl to fix it. SKIP: { skip( 'Bug in some perls UINT in GIDs', 15 ) unless $] >= 5.010; skip( 'Non-root user running tests', 15 ) unless $< == 0; skip( 'Failed to resolve nobody/nobody to test with', 15 ) unless defined $uid and defined $gid; ok( pchown( "./t/test_chown/*", $user ), 'pchown no group 1' ); $id = ( stat "./t/test_chown/foo" )[4]; is( $id, $uid, 'pchown no group 2' ); ok( pchown( "./t/test_chown/*", undef, $group ), 'pchown no user 1' ); $id = ( stat "./t/test_chown/foo" )[5]; is( $id, $gid, 'pchown no user 2' ); ok( pchown( "./t/test_chown/*", 0, 0, %errors ), 'pchown both 1' ); ok( pchownR( "./t/test_chown2", $user ), 'pchownR no group/no follow 1' ); $id = ( stat "./t/test_chown2/foo" )[4]; is( $id, $uid, 'pchownR no group/no follow 2' ); $id = ( stat "./t/test_chown/foo" )[4]; is( $id, 0, 'pchownR no group/no follow 3' ); ok( pchown( "./t/test_chown/*", 0, 0 ), 'pchown both 2' ); ok( pchownR( "./t/test_chown2", -1, $group, 1, %errors ), 'pchownR no user/follow 1' ); $id = ( stat "./t/test_chown2/foo" )[5]; is( $id, $gid, 'pchownR no user/follow 2' ); $id = ( stat "./t/test_chown/foo" )[5]; is( $id, $gid, 'pchownR no user/follow 3' ); $id = ( stat "./t/test_chown/foo" )[4]; is( $id, 0, 'pchownR no user/follow 4' ); ok( !pchown( "./t/test_chown2/roo", -1, $group, %errors ), 'pchown no user 2' ); ok( !pchownR( "./t/test_chown2/roo", -1, $group, 1, %errors ), 'pchownR no user/follow 5' ); } system('rm -rf ./t/test_chown* 2>/dev/null'); Paranoid-2.10/t/41_ipv4.t0000644000175000001440000000723012741127435014555 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 32; use Paranoid; use Paranoid::Debug; use Paranoid::Network::IPv4 qw(:all); use Paranoid::Network::Socket; #PDEBUG = 20; psecureEnv(); use strict; use warnings; my ( @net, $rv ); # Test 192.168.0.0/24 conversion @net = ipv4NetConvert('192.168.0.0/24'); is( scalar(@net), 3, 'convert 192.168.0.0/24 1' ); is( inet_ntoa( pack 'N', $net[0] ), '192.168.0.0', 'convert 192.168.0.0/24 2' ); is( inet_ntoa( pack 'N', $net[1] ), '192.168.0.255', 'convert 192.168.0.0/24 3' ); is( inet_ntoa( pack 'N', $net[2] ), '255.255.255.0', 'convert 192.168.0.0/24 4' ); # Test 192.168.0.64/28 conversion @net = ipv4NetConvert('192.168.0.64/28'); is( scalar(@net), 3, 'convert 192.168.0.64/28 1' ); is( inet_ntoa( pack 'N', $net[0] ), '192.168.0.64', 'convert 192.168.0.64/28 2' ); is( inet_ntoa( pack 'N', $net[1] ), '192.168.0.79', 'convert 192.168.0.64/28 3' ); is( inet_ntoa( pack 'N', $net[2] ), '255.255.255.240', 'convert 192.168.0.64/28 4' ); # Test 192.168.1.0/255.255.255.248 conversion @net = ipv4NetConvert('192.168.1.0/255.255.255.248'); is( scalar(@net), 3, 'convert 192.168.1.0/255.255.255.248 1' ); is( inet_ntoa( pack 'N', $net[0] ), '192.168.1.0', 'convert 192.168.1.0/255.255.255.248 2' ); is( inet_ntoa( pack 'N', $net[1] ), '192.168.1.7', 'convert 192.168.1.0/255.255.255.248 3' ); is( inet_ntoa( pack 'N', $net[2] ), '255.255.255.248', 'convert 192.168.1.0/255.255.255.248 4' ); # Test foo & undef @net = ipv4NetConvert('foo'); is( scalar(@net), 0, 'convert foo 1' ); @net = ipv4NetConvert(undef); is( scalar(@net), 0, 'convert undef 1' ); # Test intersection of 192.168.0.0/24 and 192.168.0.128/25 is( ipv4NetIntersect(qw(192.168.0.0/24 192.168.0.128/25)), 1, 'netIntersect 1' ); # Test intersection of 192.168.0.0/24 and 192.168.0.128/25 is( ipv4NetIntersect(qw(192.168.0.128/25 192.168.0.128/24)), -1, 'netIntersect 2' ); # Test intersection of 192.168.0.0/24 and 10.0.0.0/8 is( ipv4NetIntersect(qw(192.168.0.0/24 10.0.0.0/8)), 0, 'netIntersect 3' ); # Test intersection of 192.168.0.0/24 and 192.168.0.0/16 is( ipv4NetIntersect(qw(192.168.0.0/24 192.168.0.0/16)), -1, 'netIntersect 4' ); # Test intersection of 192.168.0.0/24 and 192.168.0.53 is( ipv4NetIntersect(qw(192.168.0.0/24 192.168.0.53)), 1, 'netIntersect 5' ); # Test intersection of 192.168.0.0/24 and 10.0.0.53 is( ipv4NetIntersect(qw(192.168.0.0/24 10.0.0.53)), 0, 'netIntersect 6' ); # Test intersection of 192.168.0.0/24 and foo is( ipv4NetIntersect(qw(192.168.0.0/24 foo)), 0, 'netIntersect 7' ); # Test intersection of bar and foo is( ipv4NetIntersect(qw(bar foo)), 0, 'netIntersect 8' ); # Test intersection of bar and undef is( ipv4NetIntersect( qw(bar), 'undef' ), 0, 'netIntersect 9' ); # Test str sort my @nets = qw( 127.0.0.1 192.168.0.0/16 10.1.25.30 ); my @sorted = sort ipv4StrSort @nets; is( $sorted[0], '10.1.25.30', 'ipv4StrSort 1' ); is( $sorted[1], '127.0.0.1', 'ipv4StrSort 2' ); is( $sorted[2], '192.168.0.0/16', 'ipv4StrSort 3' ); package foo; use Test::More; use Paranoid::Network::Socket; use Paranoid::Network::IPv4 qw(:all); # Test packed sort $nets[1] =~ s#/\d+$##; # foreach (@nets) { $_ = inet_aton($_) } @sorted = sort ipv4PackedSort @nets; is( $sorted[0], $nets[2], 'ipv4PackedSort 1' ); is( $sorted[1], $nets[0], 'ipv4PackedSort 2' ); is( $sorted[2], $nets[1], 'ipv4PackedSort 3' ); package bar; use Test::More; use Paranoid::Network::Socket; use Paranoid::Network::IPv4 qw(:all); # Test num sort foreach (@nets) { $_ = unpack 'N', $_ } @sorted = sort ipv4NumSort @nets; is( $sorted[0], $nets[2], 'ipv4NumSort 1' ); is( $sorted[1], $nets[0], 'ipv4NumSort 2' ); is( $sorted[2], $nets[1], 'ipv4NumSort 3' ); Paranoid-2.10/t/70_piofm.t0000644000175000001440000003707214173727422015021 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 138; use Paranoid; use Paranoid::IO::FileMultiplexer; use Paranoid::Debug; use Paranoid::IO qw(:all); use Paranoid::Process qw(:pfork); use Paranoid::Module; use Fcntl qw(:DEFAULT :flock :mode :seek); use constant DOUBLEMAX => 1019; psecureEnv(); use strict; use warnings; my ( $obj, $block, $bat, $stream, $data, %stats, %streams, @addr, $content ); my $tfile = 't/piofm-test1'; unlink $tfile if -f $tfile; #PDEBUG = 20; # Test for invalid sizes unlink $tfile if -t $tfile; ok( !defined( $obj = Paranoid::IO::FileMultiplexer->new( file => undef, blockSize => 512, ) ), 'piofm file name undefined 1' ); ok( !defined( $obj = Paranoid::IO::FileMultiplexer->new( file => '', blockSize => 512, ) ), 'piofm file name ZLS 1' ); ok( !defined( $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile, blockSize => 512, ) ), 'piofm blockSize too small 1' ); ok( !defined( $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile, blockSize => 4194304, ) ), 'piofm blockSize too big 1', ); ok( !defined( $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile, blockSize => 8190, ) ), 'piofm blockSize not divisible 1', ); # Def block size init ok( $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile ), 'piofm blockSize default 1' ); is( ( stat $tfile )[7], 4096, 'piofm default file size 1' ); $obj = undef; unlink $tfile; # Custom block size init ok( $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile, blockSize => 8192 ), 'piofm blockSize custom 1' ); is( ( stat $tfile )[7], 8192, 'piofm custom file size 1' ); # Test block methods ok( !defined( $block = Paranoid::IO::FileMultiplexer::Block->new($tfile) ), 'piofm block invalid args 1' ); ok( !defined( $block = Paranoid::IO::FileMultiplexer::Block->new( $tfile, 2 ) ), 'piofm block invalid args 2' ); ok( $block = Paranoid::IO::FileMultiplexer::Block->new( $tfile, 0, 4096 ), 'piofm block new 1' ); ok( !$block->allocate, "piofm block already allocated 1" ); ok( $block = Paranoid::IO::FileMultiplexer::Block->new( $tfile, 3, 4096 ), 'piofm block new 2' ); ok( !$block->allocate, "piofm block already allocated 2" ); ok( $block = Paranoid::IO::FileMultiplexer::Block->new( $tfile, 2, 4096 ), 'piofm block new 2' ); ok( $block->allocate, "piofm block allocate 1" ); ok( $block = Paranoid::IO::FileMultiplexer::Block->new( $tfile, 0, 4096 ), 'piofm block new 3' ); is( $block->bwrite( "hello", 4 ), 5, "piofm bwrite 1" ); is( $block->bwrite( "goodbye", 4091 ), 5, "piofm bwrite 2" ); is( $block->bread( \$data, 4, 5 ), 5, "piofm bread 1" ); is( $data, "hello", "piofm bread validate 1" ); is( $block->bread( \$data, 4091, 15 ), 5, "piofm bread 2" ); is( $data, "goodb", "piofm bread validate 2" ); is( $block->bwrite("hello"), 5, "piofm bwrite 3" ); is( $block->bread( \$data, undef, 9 ), 9, "piofm bread 3" ); is( $data, "helloello", "piofm bread validate 3" ); is( $block->bread( \$data ), 4096, "piofm bread 4" ); is( $block->bread( \$data, 2048 ), 2048, "piofm bread 5" ); is( $block->bread( \$data ), 4096, "piofm bread full block 1" ); # Test file header block methods $obj = $block = undef; unlink $tfile; $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile ); ok( !defined( $block = Paranoid::IO::FileMultiplexer::Block::FileHeader->new( $tfile, 8155 ) ), 'piofm fheader invalid args 1' ); ok( $block = Paranoid::IO::FileMultiplexer::Block::FileHeader->new( $tfile, 4096 ), 'piofm fheader new 1' ); is( $block->writeSig, 28, 'piofm fheader write 1' ); is( $block->blocks, 1, 'piofm fheader get blocks 1' ); ok( $block->writeBlocks(6), 'piofm fheader write blocks 1' ); is( $block->readBlocks, 6, 'piofm fheader read blocks 1' ); is( $block->blocks, 6, 'piofm fheader get blocks 2' ); $block->writeBlocks(1); ok( $block->readSig, 'piofm fheader readSig 1' ); %stats = $block->model; warn "Int Size: $stats{intSize}\n"; warn "Cur File Size: $stats{curFileSize} ($stats{curFSHuman})\n"; warn "Max File Size: $stats{maxFileSize} ($stats{maxFSHuman})\n"; warn "Cur Streams: $stats{curStreams}\n"; warn "Max Streams: $stats{maxStreams}\n"; warn "Max Stream Size: $stats{maxStreamSize} ($stats{maxSSHuman})\n"; # Redo in 8K blocks $obj = $block = undef; unlink $tfile; $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile, blockSize => 8192 ); ok( defined( $block = $obj->header ), 'piofm fheader 1' ); is( $block->writeSig, 28, 'piofm fheader write 2' ); ok( $block->readSig, 'piofm fheader readSig 2' ); is( $block->blocks, 1, 'piofm fheader get blocks 3' ); is( $block->blockSize, 8192, 'piofm fheader blockSize 1' ); %stats = $block->model; warn "Int Size: $stats{intSize}\n"; warn "Cur File Size: $stats{curFileSize} ($stats{curFSHuman})\n"; warn "Max File Size: $stats{maxFileSize} ($stats{maxFSHuman})\n"; warn "Cur Streams: $stats{curStreams}\n"; warn "Max Streams: $stats{maxStreams}\n"; warn "Max Stream Size: $stats{maxStreamSize} ($stats{maxSSHuman})\n"; # Delete references and reopen the file w/defaults $obj = $block = undef; ok( defined( $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile ) ), 'piofm open existing file 1' ); is( $obj->header->blockSize, 8192, 'piofm open existing block size match 1' ); # Write bad block size pseek( $tfile, 10, SEEK_SET ) and pwrite( $tfile, pack 'Nx', 8155 ); ok( !$obj->header->readSig, 'piofm bad block size in file 1' ); # Test w/new object $obj = $block = undef; ok( !defined( $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile ) ), 'piofm open existing file with bad block size 1' ); # Write bad block count $obj = $block = undef; unlink $tfile; $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile, blockSize => 8192 ); pseek( $tfile, 19, SEEK_SET ) and pwrite( $tfile, pack 'NNx', 4, 0 ); ok( !$obj->header->validateBlocks, 'piofm block count mismatch 1' ); ok( !$obj->header->readSig, 'piofm block count mismatch 2' ); # Fix header pseek( $tfile, 19, SEEK_SET ) and pwrite( $tfile, pack 'NNx', 1, 0 ); ok( $obj->header->readSig, 'piofm file header fixed 1' ); # Write extra data and test readSig again pseek( $tfile, 0, SEEK_END ) and pwrite( $tfile, pack 'xxxx' ); ok( !$obj->header->readSig, 'piofm bad file size 1' ); # Create new file for further tests $obj = $block = undef; unlink $tfile; $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile, blockSize => 8192 ); ok( $obj->header->readSig, 'piofm fheader readSig 3' ); # Test stream records in the file header ok( $obj->header->readStreams, 'piofm fheader readStreams 1' ); %streams = $obj->header->streams; is( scalar keys %streams, 0, 'piofm fheader streams 1' ); ok( !$obj->header->addStream, 'piofm fheader addStream no args 1' ); ok( !$obj->header->addStream('a'), 'piofm fheader addStream no block n 1' ); ok( !$obj->header->addStream( 'a', -1 ), 'piofm fheader addStream bad block n 1' ); %streams = $obj->header->streams; is( scalar keys %streams, 0, 'piofm fheader streams 2' ); ok( $obj->header->addStream( 'a', 1 ), 'piofm fheader addStream 1' ); %streams = $obj->header->streams; is( scalar keys %streams, 1, 'piofm fheader streams 3' ); is( $streams{a}, 1, 'piofm fheader streams bn check 1' ); ok( $obj->header->addStream( 'foo', 4 ), 'piofm fheader addStream 2' ); %streams = $obj->header->streams; is( scalar keys %streams, 2, 'piofm fheader streams 4' ); is( $streams{foo}, 4, 'piofm fheader streams bn check 2' ); # Test Stream header blocks $stream = Paranoid::IO::FileMultiplexer::Block::StreamHeader->new( $tfile, 1, 8192, 'a' ); ok( defined $stream, 'piofm sheader new 1' ); ok( !$stream->readSig, 'piofm sheader readSig before allocate 1' ); ok( $stream->allocate, 'piofm sheader allocate 1' ); ok( $stream->writeSig, 'piofm sheader writeSig 1' ); ok( !$stream->addBAT(1), 'piofm sheader addBAT invalid bn 1' ); ok( !$stream->addBAT(), 'piofm sheader addBAT invalid bn 2' ); ok( $stream->addBAT(2), 'piofm sheader addBAT 1' ); is( $stream->eos, 0, 'piofm sheader eos is zero 1' ); ok( $stream->writeEOS(127), 'piofm sheader eos set 1' ); is( $stream->eos, 127, 'piofm sheader eos is zero 1' ); ok( $stream->validateEOS, 'piofm sheader eos validate 1' ); ok( $obj->header->writeBlocks(2), 'piofm fheader writeBlocks 1' ); # Test BAT header blocks $bat = Paranoid::IO::FileMultiplexer::Block::BATHeader->new( $tfile, 2, 8192, 'a', 0 ); ok( defined $bat, 'piofm bheader new 1' ); ok( !$bat->readSig, 'piofm bheader readSig before allocate 1' ); ok( $bat->allocate, 'piofm bheader allocate 1' ); ok( $bat->writeSig, 'piofm bheader writeSig 1' ); ok( !$bat->addData(1), 'piofm bheader addData invalid bn 1' ); ok( !$bat->addData(), 'piofm bheader addData invalid bn 2' ); ok( $bat->addData(3), 'piofm bheader addData 1' ); ok( $obj->header->writeBlocks(3), 'piofm fheader writeBlocks 2' ); # Clean up first missing data block $block = Paranoid::IO::FileMultiplexer::Block->new( $tfile, 3, 8192 ); ok( defined $block, 'piofm data block new 1' ); ok( $block->allocate, 'piofm data block allocate 1' ); ok( $obj->header->writeBlocks(4), 'piofm fheader writeBlocks 3' ); # Test verification ok( !$obj->chkConsistency, 'piofm chkConsistency missing stream header 1' ); # Test corrupt flag ok( !$obj->addStream('bar'), 'piofm corrupt flag 1' ); # Fix stream foo $stream = Paranoid::IO::FileMultiplexer::Block::StreamHeader->new( $tfile, 4, 8192, 'foo' ); ok( defined $stream, 'piofm sheader new 1' ); ok( $stream->allocate, 'piofm sheader allocate 1' ); ok( $stream->writeSig, 'piofm sheader writeSig 1' ); ok( $obj->header->writeBlocks(5), 'piofm fheader writeBlocks 4' ); # Test verification ok( $obj->chkConsistency, 'piofm chkConsistency stream header fixed 1' ); # Test corrupt flag again ok( $obj->addStream('bar'), 'piofm addStream bar 1' ); is( $obj->header->blocks, 8, 'piofm blocks after bar 1' ); # Test _getStream $stream = $obj->_getStream('foo'); ok( defined $stream, 'piofm _getStream 1' ); is( $stream->streamName, 'foo', 'piofm check stream name 1' ); # Test _calcAddr @addr = $obj->_calcAddr(0); is( $addr[0], 0, 'piofm calcAddr start of stream 1' ); is( $addr[1], 0, 'piofm calcAddr start of stream 2' ); is( $addr[2], 0, 'piofm calcAddr start of stream 3' ); @addr = $obj->_calcAddr( $obj->header->blockSize / 2 ); is( $addr[0], 0, 'piofm calcAddr mid-block 1' ); is( $addr[1], 0, 'piofm calcAddr mid-block 2' ); is( $addr[2], $obj->header->blockSize / 2, 'piofm calcAddr mid-block 3' ); @addr = $obj->_calcAddr( $obj->header->blockSize ); is( $addr[0], 0, 'piofm calcAddr next block 1' ); is( $addr[1], 1, 'piofm calcAddr next block 2' ); is( $addr[2], 0, 'piofm calcAddr next block 3' ); @addr = $obj->_calcAddr( $obj->header->blockSize + ( $obj->header->blockSize / 2 ) ); is( $addr[0], 0, 'piofm calcAddr next block 4' ); is( $addr[1], 1, 'piofm calcAddr next block 5' ); is( $addr[2], $obj->header->blockSize / 2, 'piofm calcAddr next block 6' ); @addr = $obj->_calcAddr( DOUBLEMAX * 4 * $obj->header->blockSize + 7 + $obj->header->blockSize ); is( $addr[0], 4, 'piofm calcAddr far block 1' ); is( $addr[1], 1, 'piofm calcAddr far block 2' ); is( $addr[2], 7, 'piofm calcAddr far block 3' ); # Test _growStream my $blocks = $obj->header->blocks; is( $obj->_growStream( "a", $obj->_calcAddr(0) ), 1, 'piofm growStream 1' ); is( $obj->_growStream( "a", $obj->_calcAddr( $obj->header->blockSize * 4 ) ), $blocks + 3, 'piofm growStream 2' ); # Test strmWrite my $msga = 'This is stream "a". ' x 100; is( $obj->strmWrite( 'a', $msga ), length $msga, 'piofm strmWrite to a 1' ); is( $obj->strmTell('a'), length $msga, 'piofm strmTell stream a 1' ); my $msgb = 'This write 2 to stream "a". ' x 600; is( $obj->strmWrite( 'a', $msgb ), length $msgb, 'piofm strmWrite to a 2' ); is( $obj->strmTell('a'), length $msga . $msgb, 'piofm strmTell stream a 2' ); ok( $obj->strmSeek( 'a', 0, SEEK_SET ), 'piofm strmSeek 1' ); is( $obj->strmRead( 'a', \$content, length $msga ), length $msga, 'piofm strmRead a 1' ); is( $msga, $content, 'piofm stream a content match 1 ' ); is( $obj->strmRead( 'a', \$content, length $msgb ), length $msgb, 'piofm strmRead a 2' ); is( $msgb, $content, 'piofm stream a content match 2 ' ); ok( $obj->strmSeek( 'a', length($msga) - 100, SEEK_SET ), 'piofm strmSeek 2' ); is( $obj->strmRead( 'a', \$content, 200 ), 200, 'piofm strmRead a 3' ); is( $content, substr( $msga, -100 ) . substr( $msgb, 0, 100 ), 'piofm stream a content match 3' ); # Misc testing $msga = 'This is stream "foo" . ' x 1000; is( $obj->strmWrite( 'foo', $msga ), length $msga, 'piofm strmWrite to a 3' ); ok( $obj->strmAppend( 'foo', 'This is the end.' ), 'piofm strmAppend foo 1' ); ok( $obj->strmSeek( 'foo', -100, SEEK_END ), 'piofm strmSeek foo 1' ); is( $obj->strmRead( 'foo', \$content, 150 ), 100, 'piofm strmRead foo past EOS 1' ); ok( $content =~ /This is the end.$/s, 'piofm stream foo content match 1' ); ok( $obj->strmTruncate( 'foo', 20 ), 'piofm stream foo truncate 1' ); is( $obj->strmRead( 'foo', \$content, 100 ), 0, 'piofm strmRead foo past EOS 2' ); ok( $obj->strmSeek( 'foo', 0, SEEK_SET ), 'piofm strmSeek foo 2' ); is( $obj->strmRead( 'foo', \$content, 100 ), 20, 'piofm strmRead foo 1' ); # Fork-testing $SIG{CHLD} = \&sigchld; my ( $child, $pid ); SKIP: { skip( 'No Time::HiRes -- skipping permissions test', 1 ) unless loadModule( 'Time::HiRes', qw(usleep) ); $obj = $stream = $bat = $block = undef; unlink $tfile; $obj = Paranoid::IO::FileMultiplexer->new( file => $tfile, ); $obj->addStream('odds'); $obj->addStream('evens'); # Fork some children and have them all write messages to various streams foreach $child ( 1 .. 10 ) { unless ( $pid = pfork() ) { for ( 1 .. 50 ) { my $intvl = int rand 500; usleep($intvl); $obj->strmAppend( ( $child % 2 ? 'odds' : 'evens' ), "child $child: pid $$ test #$_ (slept $intvl usec)\n" ); } exit 0; } } while ( childrenCount() ) { sleep 1 } sleep 5; # Count the number of lines in each stream $obj->strmSeek( 'odds', 0, SEEK_SET ); $obj->strmRead( 'odds', \$content, 16384 ); is( scalar split( /\n/s, $content ), 250, 'piofm fork line count 1' ); # { # my @lines = split /\n/s, $content; # foreach $child ( 1, 3, 5, 7, 9 ) { # my @c1 = grep /child $child:/, @lines; # warn "\nChild $child count: @{[ scalar @c1 ]}\n"; # foreach ( @c1 ) { warn "LINE: $_\n" } # } # } $obj->strmSeek( 'evens', 0, SEEK_SET ); $obj->strmRead( 'evens', \$content, 16384 ); is( scalar split( /\n/s, $content ), 250, 'piofm fork line count 2' ); # { # my @lines = split /\n/s, $content; # foreach $child ( 2, 4, 6, 8, 10 ) { # my @c1 = grep /child $child:/, @lines; # warn "\nChild $child count: @{[ scalar @c1 ]}\n"; # foreach ( @c1 ) { warn "LINE: $_\n" } # } # } } # Cleanup # # TODO: Disable copy before shipping #system("cp -av $tfile $tfile-bak"); unlink $tfile; Paranoid-2.10/t/03_io.t0000644000175000001440000001020014162561423014265 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 52; use Paranoid; use Paranoid::Debug; use Paranoid::IO qw(:all); use Fcntl qw(:DEFAULT :seek :flock :mode); use strict; use warnings; psecureEnv(); #PIOLOCKSTACK = 1; my $f = 't/test_io.txt'; my $rlen = length "0000\n"; my ( @tmp, $text, $fh, $rv ); # Pre-emptive cleanup unlink $f if -f $f; # Calls on unopened files ok( pclose($f), 'unopened 1' ); ok( !ptell($f), 'unopened 2' ); ok( !pseek( $f, 0, SEEK_END ), 'unopened 3' ); # Check file mode ok( $fh = popen( $f, O_CREAT | O_RDWR ), 'file mode 1' ); @tmp = stat $f; ok( $tmp[2] & 07777 == 0666 ^ umask, 'file mode 2' ); ok( pclose($f), 'file mode 3' ); unlink $f; ok( $fh = popen( $f, O_CREAT | O_RDWR, S_IRUSR | S_IWUSR ), 'file mode 4' ); @tmp = stat $f; ok( ( $tmp[2] & 07777 ) == ( S_IRUSR | S_IWUSR ), 'file mode 5' ); # Check cached file handle ok( $fh == popen($f), 'popen cache 1' ); # Read empty file my ($bread); $rv = pread( $f, $bread, 100 ); ok( ( defined $rv and !$rv ), 'read empty 1' ); # Write tests $text = ''; for ( 0 .. 99 ) { $text .= sprintf( "%04d\n", $_ ) } # Normal write $rv = pwrite( $f, $text ); ok( ( $rv and length $text == $rv ), 'pwrite 1' ); pclose($f) and unlink $f; # Write w/length $rv = pwrite( $f, $text, 10 ); ok( $rv == 10, 'pwrite 2' ); # Write w/length & offset $rv = pwrite( $f, $text, 10, -10 ); ok( $rv == 10, 'pwrite 3' ); # Write w/undef $text = undef; $rv = pwrite( $f, $text, 10, -10 ); ok( !defined $rv, 'pwrite 4' ); # Read a file that was opened O_WRONLY $rv = pread( $f, $bread, 100 ); ok( !defined $rv, 'pread write-only 1' ); # Write to a file that opened O_RDONLY pclose($f); ok( $fh = popen( $f, O_RDONLY ), 'pwrite read-only 1' ); $rv = pwrite( $f, $bread ); ok( !defined $rv, 'pwrite read-only 2' ); # Test explicit r/w open pclose($f) and unlink $f; $text = ''; for ( 0 .. 99 ) { $text .= sprintf( "%04d\n", $_ ) } ok( $fh = popen( $f, O_CREAT | O_TRUNC | O_RDWR ), 'read/write 1' ); $rv = pwrite( $f, $text ); ok( ( $rv and length $text == $rv ), 'read/write 2' ); $rv = ptell($f); ok( $rv == length $text, 'read/write 3' ); $rv = pread( $f, $bread, $rlen ); ok( ( defined $rv and $rv == 0 ), 'read/write 4' ); ok( pseek( $f, 0, SEEK_SET ), 'read/write 5' ); $rv = pread( $f, $bread, $rlen ); ok( ( defined $rv and $rv == $rlen ), 'read/write 6' ); ok( $bread eq "0000\n", 'read/write 7' ); $rv = pwrite( $f, "AAAA\n" ); ok( ( $rv and $rlen == $rv ), 'read/write 8' ); ok( pseek( $f, 0, SEEK_SET ), 'read/write 9' ); $rv = pread( $f, $bread, $rlen * 2 ); ok( ( defined $rv and $rv == $rlen * 2 ), 'read/write 10' ); ok( $bread eq "0000\nAAAA\n", 'read/write 11' ); # Test fork w/O_TRUNC my $cpid = fork; if ($cpid) { wait; ok( pseek( $f, 0, SEEK_CUR ), 'fork 1' ); $rv = pread( $f, $bread, $rlen * 2 ); ok( ( defined $rv and $rv == $rlen * 2 ), 'fork 2' ); ok( $bread eq "BBBB\n0003\n", 'fork 3' ); } else { pwrite( $f, "BBBB\n" ); exit 0; } # Test pappend w/o O_APPEND $rv = ptell($f); $bread = "ZZZZ\n"; ok( pappend( $f, $bread ), 'pappend 1' ); ok( $rv == ptell($f), 'pappend 2' ); ok( pseek( $f, $rlen * -1, SEEK_END ), 'pappend 3' ); ok( pread( $f, $bread, $rlen ), 'pappend 4' ); ok( $bread eq "ZZZZ\n", 'pappend 5' ); # Test pappend w/O_APPEND pclose($f); $rv = ptell($f); ok( pappend( $f, $bread ), 'pappend 6' ); ok( $rv == ptell($f), 'pappend 7' ); # Test everything w/file handles $fh = popen($f); ok( pclose($fh), 'file handle 1' ); $fh = popen($f); ok( pflock( $f, LOCK_EX ), 'file handle 2' ); ok( pseek( $fh, 0, SEEK_END ), 'file handle 3' ); $rv = ptell($fh); ok( $rv == $rlen * 102, 'file handle 4' ); ok( pseek( $fh, 0, SEEK_SET ), 'file handle 5' ); $bread = "0000\n"; $rv = pwrite( $fh, $bread ); ok( $rv == $rlen, 'file handle 6' ); ok( pseek( $fh, 0, SEEK_SET ), 'file handle 7' ); $rv = pnlread( $fh, $bread, $rlen ); ok( $rv == $rlen, 'file handle 8' ); ok( pflock( $f, LOCK_UN ), 'file handle 9' ); # Test ptruncate ok( pseek( $fh, 0, SEEK_SET ), 'ptruncate 1' ); ok( ptruncate($fh), 'ptruncate 2' ); ok( pseek( $fh, 0, SEEK_CUR ), 'ptruncate 3' ); ok( pseek( $fh, 0, SEEK_END ), 'ptruncate 4' ); ok( ptell($fh) == 0, 'ptruncate 5' ); pclose($fh); unlink $f; Paranoid-2.10/t/07_glob.t0000644000175000001440000000442513375541157014630 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 24; use Paranoid; use Paranoid::Glob; use Paranoid::Debug; #PDEBUG = 20; psecureEnv(); use strict; use warnings; my ( $obj, @files ); mkdir 't/{asdfa-sdfas}'; symlink '{asdfa-sdfas}', 't/test-foo'; symlink 't/{asdfa-sdfas}', 't/test-bar'; ok( $obj = new Paranoid::Glob, 'glob object new 1' ); $obj = Paranoid::Glob->new( globs => ['./t///*'], ); is( grep( m#//#, @$obj ), 0, 'redundant /' ); ok( defined $obj, 'glob object new 2' ); ok( grep( qr/99_pod.t/, @$obj ), 'file found 1' ); ok( grep( qr/99_pod.t/, $obj->exists ), 'file found 2' ); $obj = Paranoid::Glob->new( literals => ['./t/*'], ); is( scalar @$obj, 1, 'literal test 1' ); is( $$obj[0], './t/*', 'literal test 2' ); is( scalar $obj->exists, 0, 'literal test 3' ); $obj = Paranoid::Glob->new( globs => ['./t/*'], ); ok( grep( qr/\{/, @$obj ), 'file found 3' ); $obj = Paranoid::Glob->new( literals => ['./t/{asdfa-sdfas}'], ); is( scalar @$obj, 1, 'file found 4' ); is( $$obj[0], './t/{asdfa-sdfas}', 'file found 5' ); $obj = Paranoid::Glob->new( globs => ['./t/{asdfa-sdfas,foo}'], ); is( scalar $obj->exists, 0, 'file found 4' ); $obj = Paranoid::Glob->new( globs => ['./t/*'], ); ok( scalar $obj->directories, 'directories found 1' ); is( scalar $obj->symlinks, 2, 'symlinks found 1' ); ok( grep( /test-bar/, $obj->symlinks ), 'symlinks found 2' ); ok( grep( /test-foo/, $obj->directories ), 'directory symlink 1' ); ok( !grep( /test-bar/, $obj->directories ), 'directory symlink 2' ); # Cleanup rmdir 't/{asdfa-sdfas}'; unlink qw(t/test-foo t/test-bar); foreach ( qw(t/test_glob1 t/test_glob2 t/test_glob1/foo t/test_glob1/bar t/test_glob2/roo t/test_glob1/foo/.hidden) ) { mkdir $_; } symlink '../../test_glob1/foo', 't/test_glob2/roo/link'; $obj = Paranoid::Glob->new( globs => ['./t/test_glob*'], ); is( @$obj, 2, 'test glob 1' ); ok( $obj->recurse, 'recurse 1' ); is( @$obj, 6, 'recurse 2' ); ok( $obj->recurse( 0, 1 ), 'recurse 3' ); is( @$obj, 7, 'recurse 4' ); ok( $obj->recurse( 1, 1 ), 'recurse 5' ); is( @$obj, 8, 'recurse 6' ); # Cleanup unlink 't/test_glob2/roo/link'; foreach ( reverse qw(t/test_glob1 t/test_glob2 t/test_glob1/foo t/test_glob1/bar t/test_glob2/roo t/test_glob1/foo/.hidden) ) { rmdir $_; } Paranoid-2.10/t/20_filesystem_pmkdir.t0000644000175000001440000000234714173376555017440 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 9; use Paranoid; use Paranoid::Debug; use Paranoid::Filesystem; use Paranoid::Glob; #PDEBUG = 20; psecureEnv(); use strict; use warnings; my $cmask = umask; my $glob; ok( pmkdir('t/test/{ab,cd,ef{1,2}}'), 'pmkdir 1' ); foreach (qw(t/test/ab t/test/cd t/test/ef1 t/test/ef2 t/test)) { rmdir $_; } SKIP: { skip( 'Running as root -- skipping permissions test', 1 ) if $< == 0; ok( !pmkdir( 't/test/{ab,cd,ef{1,2}}', 0555 ), 'pmkdir 2' ); } rmdir 't/test'; $glob = Paranoid::Glob->new( globs => ['t/test/{ab,cd,ef{1,2}}'], ); ok( pmkdir( $glob, 0750 ), 'pmkdir 3' ); my @fstat = stat 't/test/ab'; is( ( $fstat[2] & 07777 ) ^ umask, 0750 ^ umask, 'pmkdir perms 1' ); foreach (qw(t/test/ab t/test/cd t/test/ef1 t/test/ef2 t/test)) { rmdir $_; } $glob = Paranoid::Glob->new( literals => ['t/test/{ab,cd,ef{1,2}}'], ); ok( pmkdir($glob), 'pmkdir 4' ); { no warnings 'qw'; foreach (qw(t/test/{ab,cd,ef{1,2}} t/test)) { rmdir $_ } } ok( !pmkdir(undef), 'pmkdir 5' ); ok( !pmkdir( 't/test', 'mymode' ), 'pmkdir 6' ); ok( pmkdir('t/test_pmkdir/with/many/subdirs'), 'pmkdir 7' ); ok( pmkdir('t/test_pmkdir/with/many/subdirs/again'), 'pmkdir 8' ); system 'rm -rf t/test_pmkdir'; Paranoid-2.10/t/23_filesystem_ptouch.t0000644000175000001440000000364514162724524017450 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 14; use Paranoid; use Paranoid::Debug; use Paranoid::Filesystem; use Paranoid::Glob; use Config; #PDEBUG = 20; psecureEnv(); use strict; use warnings; no warnings qw(qw); my ( @stat, %errors, $glob ); ok( !ptouch( './t/test_mkdir/foo', undef ), 'ptouch missing 1' ); mkdir './t/test_touch'; ok( ptouch( './t/test_touch/foo', undef, %errors ), 'ptouch single 1' ); ok( ptouch( './t/test_touch/foo', 1000000, %errors ), 'ptouch single 2' ); @stat = stat('./t/test_touch/foo'); is( $stat[8], 1000000, 'ptouch checking atime 1' ); SKIP: { skip "NetBSD noatime prevents utime from working at all", 1 if $Config{osname} eq 'netbsd'; is( $stat[9], 1000000, 'ptouch checking mtime 1' ); } ok( ptouch('./t/test_touch/bar'), 'ptouch single 4' ); mkdir './t/test_touch2'; mkdir './t/test_touch2/foo'; symlink '../../test_touch', './t/test_touch2/foo/bar'; ok( ptouchR( './t/test_touch2', 10000000, 0, %errors ), 'ptouchR nofollow 1' ); @stat = stat('./t/test_touch2'); SKIP: { skip "NetBSD noatime prevents utime from working at all", 1 if $Config{osname} eq 'netbsd'; is( $stat[8], 10000000, 'ptouchR checking atime 1' ); } @stat = stat('./t/test_touch2/foo/bar/foo'); is( $stat[8], 1000000, 'ptouchR checking atime 2' ); ok( ptouchR( './t/test_touch2', 10000000, 1 ), 'ptouchR follow 1' ); @stat = stat('./t/test_touch2/foo/bar/foo'); SKIP: { skip "NetBSD noatime prevents utime from working at all", 1 if $Config{osname} eq 'netbsd'; is( $stat[8], 10000000, 'ptouchR checking atime 3' ); } is( $stat[9], 10000000, 'ptouchR checking mtime 2' ); ok( !ptouchR( Paranoid::Glob->new( globs => [ './t/test_touch2', './t/test_touch3/foo/bar' ] ), undef, 0, %errors ), 'ptouchR glob 1' ); ok( exists $errors{'./t/test_touch3/foo/bar'}, 'error message' ); # Cleanup system('rm -rf ./t/test_touch* 2>&1'); Paranoid-2.10/t/42_ipv6.t0000644000175000001440000001005712741127435014561 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 31; use Paranoid; use Paranoid::Debug; use Paranoid::Network::IPv6 qw(:all); use Paranoid::Network::Socket; #PDEBUG = 20; psecureEnv(); use strict; use warnings; my ( @net, $rv ); SKIP: { skip( 'Missing IPv6 support -- skipping IPv6 tests', 31 ) unless has_ipv6(); # Test ffff:ffff:ffff::/64 conversion @net = ipv6NetConvert('ffff:ffff:ffff::/64'); is( scalar(@net), 3, 'convert ffff:ffff:ffff::/64 1' ); is( inet_ntop( AF_INET6(), pack 'NNNN', @{ $net[0] } ), 'ffff:ffff:ffff::', 'convert ffff:ffff:ffff::/64 2' ); like( inet_ntop( AF_INET6(), pack 'NNNN', @{ $net[1] } ), qr/^ffff:ffff:ffff:0?:ffff:ffff:ffff:ffff$/, 'convert ffff:ffff:ffff::/64 3' ); is( inet_ntop( AF_INET6(), pack 'NNNN', @{ $net[2] } ), 'ffff:ffff:ffff:ffff::', 'convert ffff:ffff:ffff::/64 4' ); # Test ffff:ffff:ffee::/48 conversion @net = ipv6NetConvert('ffff:ffff:ffee::/48'); is( scalar(@net), 3, 'convert ffff:ffff:ffee::/48 1' ); is( inet_ntop( AF_INET6(), pack 'NNNN', @{ $net[0] } ), 'ffff:ffff:ffee::', 'convert ffff:ffff:ffee::/48 2' ); is( inet_ntop( AF_INET6(), pack 'NNNN', @{ $net[1] } ), 'ffff:ffff:ffee:ffff:ffff:ffff:ffff:ffff', 'convert ffff:ffff:ffee::/48 3' ); is( inet_ntop( AF_INET6(), pack 'NNNN', @{ $net[2] } ), 'ffff:ffff:ffff::', 'convert ffff:ffff:ffee::/48 4' ); # Test ::1 conversion @net = ipv6NetConvert('::1'); is( scalar(@net), 1, 'convert ::1 1' ); is( inet_ntop( AF_INET6(), pack 'NNNN', @{ $net[0] } ), '::1', 'convert ::1 2' ); # Test foo & undef @net = ipv6NetConvert('foo'); is( scalar(@net), 0, 'convert foo 1' ); @net = ipv6NetConvert(undef); is( scalar(@net), 0, 'convert undef 1' ); # Test intersection of 192.168.0.0/24 and 192.168.0.128/25 is( ipv6NetIntersect(qw(fe80::212:e9dd:fed9:a1f9 fe80::/64)), -1, 'netIntersect 1' ); # Test intersection of 192.168.0.0/24 and 192.168.0.128/25 is( ipv6NetIntersect(qw(fe80::/64 fe80::212:e9dd:fed9:a1f9)), 1, 'netIntersect 2' ); # Test intersection of 192.168.0.0/24 and 10.0.0.0/8 is( ipv6NetIntersect(qw(fe81::/64 fe80::212:e9dd:fed9:a1f9)), 0, 'netIntersect 3' ); # Test intersection of 192.168.0.0/24 and 192.168.0.0/16 is( ipv6NetIntersect(qw(fe80::/64 fe81::/64)), 0, 'netIntersect 4' ); # Test intersection of 192.168.0.0/24 and 192.168.0.53 is( ipv6NetIntersect(qw(192.168.0.0 fe80::212:e9dd:fed9:a1f9)), 0, 'netIntersect 5' ); # Test intersection of 192.168.0.0/24 and 10.0.0.53 is( ipv6NetIntersect(qw(192.168.0.0/24 10.0.0.53)), 0, 'netIntersect 6' ); # Test intersection of 192.168.0.0/24 and foo is( ipv6NetIntersect(qw(192.168.0.0/24 foo)), 0, 'netIntersect 7' ); # Test intersection of bar and foo is( ipv6NetIntersect(qw(bar foo)), 0, 'netIntersect 8' ); # Test intersection of bar and undef is( ipv6NetIntersect( qw(bar), 'undef' ), 0, 'netIntersect 9' ); # Test ipv6NetPacked @net = ipv6NetConvert('ff::1'); my @p = ipv6NetPacked('ff::1'); is( $p[0], pack( 'NNNN', @{ $net[0] } ), 'netPacked 1' ); # Test IPv6 string sort my @nets = qw( fe80::8d46 a2e0:f4::3/64 ::1/128 ); my @sorted = sort ipv6StrSort @nets; is( $sorted[0], '::1/128', 'ipv6StrSort 1' ); is( $sorted[1], 'a2e0:f4::3/64', 'ipv6StrSort 2' ); is( $sorted[2], 'fe80::8d46', 'ipv6StrSort 3' ); # Test IPv6 packed sort foreach (@nets) { $_ =~ s#/\d+$## }; # foreach (@nets) { $_ = inet_pton( AF_INET6(), $_ ) } @sorted = sort ipv6PackedSort @nets; is( $sorted[0], $nets[2], 'ipv6PackedSort 1' ); is( $sorted[1], $nets[1], 'ipv6PackedSort 2' ); is( $sorted[2], $nets[0], 'ipv6PackedSort 3' ); # Test IPv6 num sort foreach (@nets) { $_ = [ unpack 'NNNN', $_ ] } @sorted = sort ipv6NumSort @nets; is( $sorted[0], $nets[2], 'ipv6PackedSort 1' ); is( $sorted[1], $nets[1], 'ipv6PackedSort 2' ); is( $sorted[2], $nets[0], 'ipv6PackedSort 3' ); } Paranoid-2.10/t/12_lockfile.t0000644000175000001440000000071312741127435015460 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 6; use Paranoid; use Paranoid::IO::Lockfile; use Fcntl qw(:flock); use strict; use warnings; psecureEnv(); my $lfile = 't/test.lock'; ok( plock( $lfile, LOCK_EX, 0666 ), 'plock excluse 1' ); ok( plock($lfile), 'plock exclusive 2' ); ok( plock( $lfile, LOCK_SH ), 'plock share 1' ); ok( pexclock($lfile), 'pexclock 1' ); ok( pshlock($lfile), 'pshclock 1' ); ok( punlock($lfile), 'punlock 1' ); unlink $lfile; Paranoid-2.10/t/22_filesystem_prm.t0000644000175000001440000000401112741127435016726 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 9; use Paranoid; use Paranoid::Debug; use Paranoid::Filesystem; use Paranoid::Glob; #PDEBUG = 20; psecureEnv(); use strict; use warnings; no warnings qw(qw); my $glob; my %errors; sub touch { my $filename = shift; my $size = shift || 0; my $fh; open $fh, '>', $filename or die "Couldn't touch file $filename: $!\n"; while ( $size - 80 > 0 ) { print $fh 'A' x 79, "\n"; $size -= 80; } print $fh 'A' x $size; close $fh; } sub prep { mkdir './t/test_rm'; mkdir './t/test_rm/foo'; mkdir './t/test_rm/bar'; mkdir './t/test_rm/foo/bar'; mkdir './t/test_rm/foo/bar/roo'; touch('./t/test_rm/foo/touched'); symlink 'foo', './t/test_rm/sym1'; symlink 'fooo', './t/test_rm/sym2'; } # start testing prep(); ok( !prm( './t/test_rm', %errors ), 'prm single 1' ); ok( prm(Paranoid::Glob->new( globs => [ qw(./t/test_rm/bar ./t/test_rm/foo/touched) ] ), %errors ), 'prm glob 1' ); touch('./t/test_rm/foo/touched'); ok( prm(Paranoid::Glob->new( globs => [ qw(./t/test_rm/* ./t/test_rm/foo ./t/test_rm/foo/{*/,}*) ] ), %errors ), 'prm glob 2' ); # Test recursive function prep(); ok( prmR( './t/test_rm2/foo', 0, %errors ), 'prmR 1' ); mkdir './t/test_rm2/foo'; symlink '../../test_rm/foo', './t/test_rm2/foo/bar'; ok( prmR( './t/test_rm*', 0, %errors ), 'prmR 2' ); ok( !-d './t/test_rm', 'prmR 3' ); ok( prmR( './t/test_rm_not_there', 0, %errors ), 'prmR 4' ); mkdir './t/test_rm_noperms'; mkdir './t/test_rm_noperms/foo'; SKIP: { skip( 'Running as root -- skipping permissions test', 1 ); chmod 0400, './t/test_rm_noperms'; ok( !prmR( './t/test_rm_noperms/foo', 0, %errors ), 'prmR 5' ); } chmod 0755, './t/test_rm_noperms'; ok( prmR( './t/test_rm_noperms', 0, %errors ), 'prmR 6' ); system("rm -rf ./t/test_rm_noperms"); Paranoid-2.10/t/10_io_line-lockstack.t0000644000175000001440000001064114161231555017256 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 47; use Paranoid; use Paranoid::IO qw(:all); use Paranoid::IO::Line qw(:all); use Paranoid::Debug; use Fcntl qw(:DEFAULT :mode :seek :flock); use strict; use warnings; psecureEnv(); my ( $val, $fh, $f, $l, @lines, $rv, @all ); # Create another test file for sip PIOMAXFSIZE = 4096; PIOBLKSIZE = 512; PIOLOCKSTACK = 1; $l = "1" x 78 . "\15\12"; $val = int( ( 6 * 1024 ) / length $l ); $f = "./t/test24KB"; open $fh, '>', $f or die "failed to open file: $!\n"; for ( 1 .. $val ) { print $fh $l } for ( 1 .. $val ) { print $fh '0' x 80 } for ( 1 .. $val ) { print $fh $l } for ( 1 .. $val ) { print $fh '0' x 80 } close $fh; # Sip block 1 is( sip( $f, @lines ), 51, 'sip block 1 - 1' ); is( $lines[0], $l, 'sip block 1 - 2' ); push @all, @lines; # Sip block 2 is( sip( $f, @lines ), undef, 'sip block 2 - 1' ); push @all, @lines; is( scalar @lines, 25, 'sip block 2 - 2' ); # Sip block 3 is( sip( $f, @lines ), '0 but true', 'sip block 3 - 1' ); push @all, @lines; is( scalar @lines, 0, 'sip block 3 - 2' ); # Sip block 4 is( sip( $f, @lines ), 51, 'sip block 4 - 1' ); push @all, @lines; # Sip block 5 is( sip( $f, @lines ), undef, 'sip block 5 - 1' ); push @all, @lines; is( scalar @lines, 24, 'sip block 5 - 2' ); # Sip block 6 is( sip( $f, @lines ), undef, 'sip block 6 - 1' ); push @all, @lines; is( scalar @lines, 0, 'sip block 6 - 2' ); # Sip block 7 is( sip( $f, @lines ), '0 but true', 'sip block 7 - 1' ); push @all, @lines; is( scalar @lines, 0, 'sip block 7 - 2' ); # Add some content, try sipping some more content open $fh, '>>', $f or die "failed to open file: $!\n"; for ( 1 .. $val ) { print $fh "2" x 78 . "\12" } close $fh; # Sip block 8 (with autochomp) is( sip( $f, @lines, 1 ), 50, 'sip block 8 - 1' ); push @all, @lines; # Test no chomp/chomp is( length $all[0], 80, 'sip no pchomp 1' ); is( length $all[-1], 78, 'sip pchomp 1' ); is( $all[-1], '2' x 78, 'sip pchomp 2' ); # Sip block 9 & 10 is( sip( $f, @lines, 1 ), 25, 'sip block 9 - 1' ); is( sip( $f, @lines, 1 ), '0 but true', 'sip block 10 - 1' ); # Tailf and piolClose ok( piolClose($f), 'piolClose 1' ); is( tailf( $f, @lines, 0 ), 10, 'tailf 1' ); ok( piolClose($f), 'piolClose 2' ); is( tailf( $f, @lines, 0, -75 ), 75, 'tailf 2' ); ok( piolClose($f), 'piolClose 3' ); # Multiplea tail test ok( popen( $f, O_RDWR ), 'multiple tailf 1' ); is( tailf( $f, @lines, 0, -1 ), 1, 'multiple tailf 2' ); is( tailf( $f, @lines, 0, -1 ), '0 but true', 'multiple tailf 3' ); ok( pappend( $f, "line 1\n,line 2\nline 3" ), 'multiple tailf 4' ); is( tailf( $f, @lines, 0, -1 ), 2, 'multiple tailf 5' ); ok( pappend( $f, "\n" ), 'multiple tailf 6' ); is( tailf( $f, @lines, 0, -1 ), 1, 'multiple tailf 7' ); is( $lines[0], "line 3\n", 'multiple tailf 8' ); # Test truncate open $fh, '>', $f or die "failed to open file: $!\n"; print $fh "line a\nline b\nline c\n"; close $fh; is( tailf( $f, @lines, 0, -4 ), 3, 'multiple tailf 11' ); is( $lines[0], "line a\n", 'multiple tailf 12' ); # Test overwrite unlink $f; open $fh, '>', $f or die "failed to open file: $!\n"; print $fh "testing\ntesting\n"; close $fh; is( tailf( $f, @lines, 0, -4 ), 2, 'multiple tailf 13' ); is( $lines[0], "testing\n", 'multiple tailf 14' ); is( $lines[1], "testing\n", 'multiple tailf 15' ); # Test delete unlink $f; is( tailf( $f, @lines, 0, -4 ), undef, 'multiple tailf 16' ); # Test slurp # # Create a test file PIOMAXFSIZE = 16 * 1024; $val = int( ( 4 * 1024 ) / length $l ); $f = "./t/test4KB"; open $fh, '>', $f or die "failed to open file: $!\n"; for ( 1 .. $val ) { print $fh $l } close $fh; # Test small file ok( slurp( $f, @lines ), 'slurp w/4KB file 1' ); ok( @lines == $val, 'slurp w/4KB file 2' ); # Test filehandle slurp open $fh, '<', $f or die "failed to open file: $!\n"; ok( slurp( $fh, @lines ), 'slurp w/filehandle 1' ); ok( @lines == $val, 'slurp w/filehandle 2' ); ok( !slurp( $fh, @lines ), 'slurp w/filehandle 3' ); ok( @lines == 0, 'slurp w/filehandle 4' ); close $fh; # Create a larger test file $val = int( ( 24 * 1024 ) / length $l ); $f = "./t/test24KB"; open $fh, '>', $f or die "failed to open file: $!\n"; for ( 1 .. $val ) { print $fh $l } close $fh; # Test a larger file ok( !slurp( $f, @lines ), 'slurp w/24KB file 1' ); ok( scalar @lines, 'slurp w/24KB file 2' ); # Test reading non-existant file $f = "./t/foo-test"; ok( !slurp( $f, @lines ), 'slurp\'ing non-existent file' ); unlink qw(./t/test4KB ./t/test24KB); Paranoid-2.10/t/40_socket.t0000644000175000001440000000103612741127435015160 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 3; use Paranoid; use Paranoid::Network::Socket qw(:all); psecureEnv(); use strict; use warnings; my $rv; # Test for import of sockaddr_in ok( ( defined *main::sockaddr_in{CODE} ), 'sockaddr_in 1' ); # Test for output of has_ipv6 matching presence of sockaddr_in6 if ( has_ipv6() ) { ok( ( defined *main::sockaddr_in6{CODE} ), 'sockaddr_in6 1y' ); } else { ok( ( !defined *main::sockaddr_in6{CODE} ), 'sockaddr_in6 1n' ); } # Test for import of CRLF is( CRLF, "\015\012", "CRLF 1" ); Paranoid-2.10/t/24_filesystem_misc.t0000644000175000001440000000262212741127435017073 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 12; use Paranoid; use Paranoid::Debug; use Paranoid::Filesystem qw(:all); use Paranoid::Glob; #PDEBUG = 20; psecureEnv(); use strict; use warnings; no warnings qw(qw); my $rv; # Test pcleanPath $rv = pcleanPath('/usr/sbin/../ccs/share/../../local/bin'); is( $rv, '/usr/local/bin', 'pcleanPath 1' ); $rv = pcleanPath('t/../foo/bar'); is( $rv, 'foo/bar', 'pcleanPath 2' ); $rv = pcleanPath('../t/../foo/bar'); is( $rv, '../foo/bar', 'pcleanPath 3' ); $rv = pcleanPath('../t/../foo/bar/..'); is( $rv, '../foo', 'pcleanPath 4' ); $rv = pcleanPath('../t/../foo/bar/.'); is( $rv, '../foo/bar', 'pcleanPath 5' ); $rv = pcleanPath('/../.././../t/../foo/bar/.'); is( $rv, '/foo/bar', 'pcleanPath 6' ); ok( !eval '$rv = pcleanPath(undef)', 'pcleanPath 7' ); # Test ptranslateLink mkdir './t/test_fs'; mkdir './t/test_fs/subdir'; symlink '../test_fs/link', './t/test_fs/link'; symlink 'subdir', './t/test_fs/ldir'; $rv = ptranslateLink('./t/test_fs/ldir'); is( $rv, './t/test_fs/subdir', 'ptranslateLink 1' ); $rv = ptranslateLink('t/test_fs/ldir'); is( $rv, 't/test_fs/subdir', 'ptranslateLink 2' ); # TODO: test with optional boolean # Test pwhich my $filename = pwhich('ls'); isnt( $filename, undef, 'pwhich 1' ); ok( $filename =~ m#/ls$#sm, 'pwhich 2' ); $filename = pwhich('lslslslslslslslslslsl'); is( $filename, undef, 'pwhich 3' ); system('rm -rf ./t/test_fs*'); Paranoid-2.10/t/31_log_buffer.t0000644000175000001440000000330612741127435016004 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 20; use Paranoid; use Paranoid::Log; use Paranoid::Debug qw(:all); use strict; use warnings; psecureEnv(); ok( startLogger( 'foo', 'Buffer', PL_WARN, PL_EQ ), 'startLogger 1' ); ok( plog( PL_WARN, 'this is a test' ), 'plog 1' ); is( scalar( Paranoid::Log::Buffer::dumpBuffer('foo') ), 1, 'dumpBuffer 1' ); my @msgs = Paranoid::Log::Buffer::dumpBuffer('foo'); is( $msgs[0][1], 'this is a test', 'check message 1' ); ok( plog( PL_CRIT, 'this is a test' ), 'plog 2' ); is( scalar( Paranoid::Log::Buffer::dumpBuffer('foo') ), 1, 'dumpBuffer 2' ); ok( startLogger( 'bar', 'Buffer', PL_WARN, PL_NE ), 'startLogger 2' ); ok( plog( PL_WARN, 'this is a test' ), 'plog 3' ); is( scalar( Paranoid::Log::Buffer::dumpBuffer('bar') ), 0, 'dumpBuffer 3' ); ok( plog( PL_CRIT, 'this is a test' ), 'plog 4' ); is( scalar( Paranoid::Log::Buffer::dumpBuffer('bar') ), 1, 'dumpBuffer 4' ); ok( plog( PL_DEBUG, 'this is a test' ), 'plog 5' ); is( scalar( Paranoid::Log::Buffer::dumpBuffer('bar') ), 2, 'dumpBuffer 5' ); for my $n ( 1 .. 50 ) { plog( PL_DEBUG, "test number $n" ); } is( scalar( Paranoid::Log::Buffer::dumpBuffer('bar') ), 20, 'dumpBuffer 6' ); @msgs = Paranoid::Log::Buffer::dumpBuffer('bar'); is( $msgs[0][1], 'test number 31', 'check message 2' ); is( $msgs[$#msgs][1], 'test number 50', 'check message 3' ); ok( stopLogger('bar'), 'stopLogger 1' ); ok( startLogger( 'bar', 'Buffer', PL_WARN, PL_NE, { size => 30 } ), 'startLogger 3' ); for my $n ( 1 .. 50 ) { plog( PL_DEBUG, "test number $n" ); } @msgs = Paranoid::Log::Buffer::dumpBuffer('bar'); is( $msgs[0][1], 'test number 21', 'check message 4' ); is( $msgs[$#msgs][1], 'test number 50', 'check message 5' ); Paranoid-2.10/t/03_io-lockstack.t0000644000175000001440000001017514162561364016260 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 52; use Paranoid; use Paranoid::Debug; use Paranoid::IO qw(:all); use Fcntl qw(:DEFAULT :seek :flock :mode); use strict; use warnings; psecureEnv(); PIOLOCKSTACK = 1; my $f = 't/test_io.txt'; my $rlen = length "0000\n"; my ( @tmp, $text, $fh, $rv ); # Pre-emptive cleanup unlink $f if -f $f; # Calls on unopened files ok( pclose($f), 'unopened 1' ); ok( !ptell($f), 'unopened 2' ); ok( !pseek( $f, 0, SEEK_END ), 'unopened 3' ); # Check file mode ok( $fh = popen( $f, O_CREAT | O_RDWR ), 'file mode 1' ); @tmp = stat $f; ok( $tmp[2] & 07777 == 0666 ^ umask, 'file mode 2' ); ok( pclose($f), 'file mode 3' ); unlink $f; ok( $fh = popen( $f, O_CREAT | O_RDWR, S_IRUSR | S_IWUSR ), 'file mode 4' ); @tmp = stat $f; ok( ( $tmp[2] & 07777 ) == ( S_IRUSR | S_IWUSR ), 'file mode 5' ); # Check cached file handle ok( $fh == popen($f), 'popen cache 1' ); # Read empty file my $bread; $rv = pread( $f, $bread, 100 ); ok( ( defined $rv and !$rv ), 'read empty 1' ); # Write tests $text = ''; for ( 0 .. 99 ) { $text .= sprintf( "%04d\n", $_ ) } # Normal write $rv = pwrite( $f, $text ); ok( ( $rv and length $text == $rv ), 'pwrite 1' ); pclose($f) and unlink $f; # Write w/length $rv = pwrite( $f, $text, 10 ); ok( $rv == 10, 'pwrite 2' ); # Write w/length & offset $rv = pwrite( $f, $text, 10, -10 ); ok( $rv == 10, 'pwrite 3' ); # Write w/undef $text = undef; $rv = pwrite( $f, $text, 10, -10 ); ok( !defined $rv, 'pwrite 4' ); # Read a file that was opened O_WRONLY $rv = pread( $f, $bread, 100 ); ok( !defined $rv, 'pread write-only 1' ); # Write to a file that opened O_RDONLY pclose($f); ok( $fh = popen( $f, O_RDONLY ), 'pwrite read-only 1' ); $rv = pwrite( $f, $bread ); ok( !defined $rv, 'pwrite read-only 2' ); # Test explicit r/w open pclose($f) and unlink $f; $text = ''; for ( 0 .. 99 ) { $text .= sprintf( "%04d\n", $_ ) } ok( $fh = popen( $f, O_CREAT | O_TRUNC | O_RDWR ), 'read/write 1' ); $rv = pwrite( $f, $text ); ok( ( $rv and length $text == $rv ), 'read/write 2' ); $rv = ptell($f); ok( $rv == length $text, 'read/write 3' ); $rv = pread( $f, $bread, $rlen ); ok( ( defined $rv and $rv == 0 ), 'read/write 4' ); ok( pseek( $f, 0, SEEK_SET ), 'read/write 5' ); $rv = pread( $f, $bread, $rlen ); ok( ( defined $rv and $rv == $rlen ), 'read/write 6' ); ok( $bread eq "0000\n", 'read/write 7' ); $rv = pwrite( $f, "AAAA\n" ); ok( ( $rv and $rlen == $rv ), 'read/write 8' ); ok( pseek( $f, 0, SEEK_SET ), 'read/write 9' ); $rv = pread( $f, $bread, $rlen * 2 ); ok( ( defined $rv and $rv == $rlen * 2 ), 'read/write 10' ); ok( $bread eq "0000\nAAAA\n", 'read/write 11' ); # Test fork w/O_TRUNC my $cpid = fork; if ($cpid) { wait; ok( pseek( $f, 0, SEEK_CUR ), 'fork 1' ); $rv = pread( $f, $bread, $rlen * 2 ); ok( ( defined $rv and $rv == $rlen * 2 ), 'fork 2' ); ok( $bread eq "BBBB\n0003\n", 'fork 3' ); } else { pwrite( $f, "BBBB\n" ); exit 0; } # Test pappend w/o O_APPEND $rv = ptell($f); $bread = "ZZZZ\n"; ok( pappend( $f, $bread ), 'pappend 1' ); ok( $rv == ptell($f), 'pappend 2' ); ok( pseek( $f, $rlen * -1, SEEK_END ), 'pappend 3' ); ok( pread( $f, $bread, $rlen ), 'pappend 4' ); ok( $bread eq "ZZZZ\n", 'pappend 5' ); # Test pappend w/O_APPEND pclose($f); $rv = ptell($f); ok( pappend( $f, $bread ), 'pappend 6' ); ok( $rv == ptell($f), 'pappend 7' ); # Test everything w/file handles $fh = popen($f); ok( pclose($fh), 'file handle 1' ); $fh = popen($f); ok( pflock( $f, LOCK_EX ), 'file handle 2' ); ok( pseek( $fh, 0, SEEK_END ), 'file handle 3' ); $rv = ptell($fh); ok( $rv == $rlen * 102, 'file handle 4' ); ok( pseek( $fh, 0, SEEK_SET ), 'file handle 5' ); $bread = "0000\n"; $rv = pwrite( $fh, $bread ); ok( $rv == $rlen, 'file handle 6' ); ok( pseek( $fh, 0, SEEK_SET ), 'file handle 7' ); $rv = pnlread( $fh, $bread, $rlen ); ok( $rv == $rlen, 'file handle 8' ); ok( pflock( $f, LOCK_UN ), 'file handle 9' ); # Test ptruncate ok( pseek( $fh, 0, SEEK_SET ), 'ptruncate 1' ); ok( ptruncate($fh), 'ptruncate 2' ); ok( pseek( $fh, 0, SEEK_CUR ), 'ptruncate 3' ); ok( pseek( $fh, 0, SEEK_END ), 'ptruncate 4' ); ok( ptell($fh) == 0, 'ptruncate 5' ); pclose($fh); unlink $f; Paranoid-2.10/t/11_args.t0000644000175000001440000001011713424436521014620 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 39; use Paranoid; use Paranoid::Args qw(:all); use Paranoid::Debug; use strict; use warnings; psecureEnv(); my ( %options, @args, @errors ); my @templates = ( { Short => 'v', Long => 'verbose', CountShort => 1, }, { Short => 'V', Long => 'VERBOSE', Template => '$', }, { Short => 'P', Long => 'pad', Template => '$@', }, { Short => 'f', Long => 'foo', Template => '$', Multiple => 1, CanBundle => 1, }, { Long => 'test', Template => '$$@$', }, { Short => 'x', Long => 'with-x', Template => '$', AccompaniedBy => [qw(y)], }, { Short => 'y', Long => 'with-y', Template => '$', AccompaniedBy => [qw(x)], }, { Short => 'z', Long => 'with-z', Template => '$', ExclusiveOf => [qw(y x)], }, ); # Test parseArgs @args = qw(-vvv -V5); ok( parseArgs( @templates, %options, @args ), 'parseArgs 1a' ); is( $options{v}, 3, 'v == 3' ); is( $options{verbose}, 3, 'verbose == 3' ); is( $options{V}, 5, 'VERBOSE == 5' ); @args = qw(-V55); ok( parseArgs( @templates, %options, @args ), 'parseArgs 1b' ); is( $options{V}, 55, 'VERBOSE == 55' ); @args = qw(-vvv --VERBOSE=7 --verbose 1 -v); ok( parseArgs( @templates, %options, @args ), 'parseArgs 2' ); is( $options{v}, 2, 'v == 2' ); is( $options{VERBOSE}, 7, 'VERBOSE == 7' ); @args = qw(-P /tmp foo bar roo); ok( parseArgs( @templates, %options, @args ), 'parseArgs 3' ); is( $options{P}[0], '/tmp', 'P/0 == "/tmp"' ); is( $options{P}[1][1], 'bar', 'P/1/1 == "bar"' ); @args = qw(-P /tmp roo -ff foo1 foo2 bar bar roo); ok( parseArgs( @templates, %options, @args ), 'parseArgs 4' ); is( $options{f}[0], 'foo1', 'f/0 == "foo1"' ); is( $options{f}[1], 'foo2', 'f/1 == "foo2"' ); is( $options{PAYLOAD}[2], 'roo', 'PAYLOAD/2 == "roo"' ); @args = qw(--test one two three four five six seven); ok( parseArgs( @templates, %options, @args ), 'parseArgs 5' ); is( $options{test}[2][1], 'four', 'test/2/1 == "four"' ); is( $options{test}[3], 'seven', 'test/3 == "seven"' ); @args = qw(-vvv foo bar -- -f --test); ok( parseArgs( @templates, %options, @args ), 'parseArgs 6' ); is( $options{PAYLOAD}[2], '-f', 'PAYLOAD/2 == "-f"' ); @args = qw(--test one two -- six -P --pad seven); ok( parseArgs( @templates, %options, @args ), 'parseArgs 7' ); is( $options{test}[2][1], '-P', 'test/2/1 == "-P"' ); @args = qw(--test one two seven); ok( !parseArgs( @templates, %options, @args ), 'parseArgs 8' ); @errors = Paranoid::Args::listErrors(); like( $errors[0], qr/missing the min/smi, 'error string matches 1' ); @args = qw(--with-x 5 -y334 -z 10); ok( !parseArgs( @templates, %options, @args ), 'parseArgs 9' ); @errors = Paranoid::Args::listErrors(); like( $errors[0], qr/cannot be called/smi, 'error string matches 2' ); @args = qw(--with-x 5); ok( !parseArgs( @templates, %options, @args ), 'parseArgs 10' ); @errors = Paranoid::Args::listErrors(); like( $errors[0], qr/must be called/smi, 'error string matches 3' ); @args = qw(--with-x 5 -y 5 --what); ok( !parseArgs( @templates, %options, @args ), 'parseArgs 10' ); @errors = Paranoid::Args::listErrors(); like( $errors[0], qr/unknown option/smi, 'error string matches 4' ); @args = qw(--with-x 5 -y 5 ---what); ok( !parseArgs( @templates, %options, @args ), 'parseArgs 10' ); @errors = Paranoid::Args::listErrors(); like( $errors[0], qr/unknown option/smi, 'error string matches 5' ); @templates = ( PA_DEBUG, PA_VERBOSE, PA_VERSION, PA_HELP ); @args = qw(-DDDvv --help --version); ok( parseArgs( @templates, %options, @args ), 'templates 1' ); @errors = Paranoid::Args::listErrors(); is( scalar @errors, 0, 'template errors 1' ); is( $options{verbose}, 2, 'template verification 1' ); is( $options{debug}, 3, 'template verification 2' ); is( $options{help}, 1, 'template verification 3' ); is( $options{version}, 1, 'template verification 4' ); Paranoid-2.10/t/32_log_file.t0000644000175000001440000000454213322651261015451 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 13; use Paranoid; use Paranoid::Log; use Paranoid::Process qw(:pfork); use Paranoid::IO::Line; use Paranoid::Debug; use Paranoid::Module; use Fcntl qw(:DEFAULT :flock :mode :seek); psecureEnv(); $SIG{CHLD} = \&sigchld; my ( $child, $pid, @lines, $line, $i, $j ); my $file = './t/foo.log'; # Load a bad facility ok( !startLogger( 'foo', 'File', PL_WARN, PL_EQ ), 'startLogger 1' ); ok( plog( PL_WARN, 'this is a test' ), 'plog 1' ); ok( stopLogger('foo'), 'stopLogger 1' ); ok( startLogger( 'foo', 'File', PL_WARN, PL_EQ, { file => $file, syslog => 1 } ), 'startLogger 2' ); ok( plog( PL_WARN, "this is a test" ), 'plog 2' ); SKIP: { skip( 'No Time::HiRes -- skipping permissions test', 1 ) unless loadModule( 'Time::HiRes', qw(usleep) ); # Fork some children and have them all log fifty messages each foreach $child ( 1 .. 5 ) { unless ( $pid = pfork() ) { for ( 1 .. 50 ) { my $intvl = int rand 500; usleep($intvl); plog( PL_WARN, "child $child: this is test #$_ (slept $intvl usec)" ); } exit 0; } } while ( childrenCount() ) { sleep 1 } sleep 5; # Count the number of lines -- should be 251 piolClose($file); slurp( $file, @lines, 1 ); my $rv = ( scalar @lines == 251 or scalar @lines == 252 ); ok( $rv, 'line count' ); # Make sure children have been logging at the same time and not blocked # by advisory locks, etc. $i = $j = 0; while (@lines) { $line = shift @lines; if ($line =~ /child 2:/s) { $i++; $i += $j; $j = 0; } elsif ($i) { $j++; } } ok( $i > 55, 'multiple children logged' ); } ok( stopLogger('foo'), 'stopLogger 2' ); ok( startLogger( 'foo', 'File', PL_WARN, PL_GE, { file => $file, mode => O_TRUNC | O_RDWR, } ), 'logger options 1' ); my @fstats = stat $file; is( $fstats[7], 0, 'file size' ); ok( stopLogger('foo'), 'stopLogger 2' ); unlink $file; ok( startLogger( 'foo', 'File', PL_WARN, PL_GE, { file => $file, perm => 0600, mode => O_CREAT | O_RDWR, } ), 'logger options 2' ); @fstats = stat $file; is( $fstats[2] & 077777, 0600, 'file perm' ); unlink $file; Paranoid-2.10/t/60_avltree.t0000644000175000001440000000727714211614431015340 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 59; use Paranoid; use Paranoid::Data::AVLTree; use Paranoid::Debug; #PDEBUG = 20; psecureEnv(); use strict; use warnings; my ($obj); my @data = ( [ foo => "bar foo" ], [ goo => "bar goo" ], [ hoo => "bar hoo" ], [ joo => "bar joo" ], [ koo => "bar koo" ], [ loo => "bar loo" ], [ boo => "bar boo" ], [ coo => "bar coo" ], [ doo => "bar doo" ], ); # Test basic operation with one node ok( $obj = new Paranoid::Data::AVLTree, 'avltree object new 1' ); is( $obj->count, 0, 'avltree count 1' ); is( $obj->height, 0, 'avltree height 1' ); is( $obj->nodeExists('foo'), 0, 'avltree exists 1' ); ok( $obj->addPair( 'foo', 'bar' ), 'avltree add 1' ); is( $obj->fetchVal('foo'), 'bar', 'avltree fetch val 1' ); is( $obj->count, 1, 'avltree count 2' ); is( $obj->height, 1, 'avltree height 2' ); # Test with multiple options ok( $obj = new Paranoid::Data::AVLTree, 'avltree object new 2' ); foreach (@data) { $obj->addPair(@$_); #warn "\nKEYS: @{[ $obj->nodeKeys ]}\n"; #$obj->dumpKeys; } is( $obj->count, 9, 'avltree count 3' ); is( $obj->height, 4, 'avltree height 3' ); ok( $obj->nodeExists('loo'), 'avltree nodeExists 1' ); ok( $obj->nodeExists('boo'), 'avltree nodeExists 2' ); ok( $obj->delNode('joo'), 'avltree delete 1' ); is( $obj->count, 8, 'avltree count 3' ); is( $obj->height, 4, 'avltree height 3' ); ok( $obj->delNode('loo'), 'avltree delete 2' ); is( $obj->count, 7, 'avltree count 4' ); is( $obj->height, 3, 'avltree height 4' ); ok( $obj->delNode('koo'), 'avltree delete 3' ); is( $obj->count, 6, 'avltree count 5' ); is( $obj->height, 3, 'avltree height 5' ); ok( $obj->delNode('foo'), 'avltree delete 4' ); is( $obj->count, 5, 'avltree count 6' ); is( $obj->height, 3, 'avltree height 6' ); # Test save/load functionality and profiling ok( $obj->save2File('t/avl.dump'), 'avltree save2File 1' ); my $obj2 = new Paranoid::Data::AVLTree; ok( $obj2->profile(1), 'avltree profile 1' ); ok( $obj2->loadFromFile('t/avl.dump'), 'avltree loadFile 1' ); is( $obj2->count, 5, 'avltree loadFile count 1' ); is( $obj2->height, 3, 'avltree loadFile height 1' ); #warn "\nKEYS: @{[ $obj2->nodeKeys ]}\n"; #$obj2->dumpKeys; foreach my $key ( $obj->nodeKeys ) { ok( $obj2->nodeExists($key), "avltree loadFile key $key exists" ); is( $obj->fetchVal($key), $obj2->fetchVal($key), "avltree loadFile $key value check" ); } my %stats = $obj2->stats; is( scalar keys %stats, 4, 'avltree stats entries check 1' ); foreach ( keys %stats ) { warn "Stat $_: $stats{$_}\n"; } #warn" First object:\n"; #$obj->dumpKeys; #warn" Second object:\n"; #$obj2->dumpKeys; # Test purge ok( $obj->purgeNodes, 'avltree purge 1' ); is( $obj->count, 0, 'avltree count 7' ); is( $obj->height, 0, 'avltree height 7' ); # Test tied interface my %test; $obj = undef; $obj = tie %test, 'Paranoid::Data::AVLTree'; ok( defined $obj, 'avltree tie 1' ); is( scalar keys %test, 0, 'avltree keys 1' ); is( $obj->height, 0, 'avltree height 8' ); ok( !exists $test{'foo'}, 'avltree exists 1' ); $test{'foo'} = 'bar'; is( $test{foo}, 'bar', 'avltree fetch val 2' ); is( scalar keys %test, 1, 'avltree keys 2' ); is( $obj->height, 1, 'avltree height 9' ); %test = (); is( scalar keys %test, 0, 'avltree purge-keys 1' ); foreach (@data) { $test{ $$_[0] } = $$_[1]; } is( scalar keys %test, 9, 'avltree keys 3' ); is( $obj->height, 4, 'avltree height 10' ); ok( exists $test{loo}, 'avltree exists 2' ); ok( exists $test{boo}, 'avltree exists 3' ); ok( delete $test{joo}, 'avltree delete 1' ); is( scalar keys %test, 8, 'avltree keys 5' ); is( $obj->height, 4, 'avltree height 11' ); Paranoid-2.10/t/02_pdebug.t0000644000175000001440000000130112741127435015127 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 9; use Paranoid; use Paranoid::Debug; use strict; use warnings; psecureEnv(); my $msg = 'This is a test'; my $out; ok( $out = pdebug($msg), 'pdebug 1' ); ok( $out = pdebug( $msg, 1, qw(foo bar) ), 'pdebug 2' ); ok( $out =~ m#$msg$#sm, 'pdebug 3' ); $msg = 'This is a %s test of %s'; ok( $out = pdebug($msg), 'pdebug 4' ); ok( $out =~ m#This is a undef test of undef$#sm, 'pdebug 5' ); ok( $out = pdebug( $msg, 1, qw(foo bar) ), 'pdebug 6' ); ok( $out =~ m#This is a foo test of bar$#sm, 'pdebug 7' ); $msg = 'This is a %s test of %.3f'; ok( $out = pdebug( $msg, 1, qw(foo bar) ), 'pdebug 8' ); ok( $out =~ m#This is a foo test of 0.000$#sm, 'pdebug 9' ); Paranoid-2.10/t/12_lockfile-lockstack.t0000644000175000001440000000100114057341666017431 0ustar acorlissusers#!/usr/bin/perl -T use Test::More tests => 6; use Paranoid; use Paranoid::IO qw(PIOLOCKSTACK); use Paranoid::IO::Lockfile; use Fcntl qw(:flock); use strict; use warnings; psecureEnv(); PIOLOCKSTACK = 1; my $lfile = 't/test.lock'; ok( plock( $lfile, LOCK_EX, 0666 ), 'plock excluse 1' ); ok( plock($lfile), 'plock exclusive 2' ); ok( plock( $lfile, LOCK_SH ), 'plock share 1' ); ok( pexclock($lfile), 'pexclock 1' ); ok( pshlock($lfile), 'pshclock 1' ); ok( punlock($lfile), 'punlock 1' ); unlink $lfile; Paranoid-2.10/lib/0000750000175000001440000000000014211616225013470 5ustar acorlissusersParanoid-2.10/lib/Paranoid/0000750000175000001440000000000014211616225015225 5ustar acorlissusersParanoid-2.10/lib/Paranoid/Data.pm0000644000175000001440000003277714211615520016456 0ustar acorlissusers# Paranoid::Data -- Misc. Data Manipulation Functions # # $Id: lib/Paranoid/Data.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ # # This software is free software. Similar to Perl, you can redistribute it # and/or modify it under the terms of either: # # a) the GNU General Public License # as published by the # Free Software Foundation ; either version 1 # , or any later version # , or # b) the Artistic License 2.0 # , # # subject to the following additional term: No trademark rights to # "Paranoid" have been or are conveyed under any of the above licenses. # However, "Paranoid" may be used fairly to describe this unmodified # software, in good faith, but not as a trademark. # # (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com) # (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com) # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::Data; use 5.008; use strict; use warnings; use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS); use base qw(Exporter); use Paranoid; use Paranoid::Debug qw(:all); use Carp; ($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm ); @EXPORT = qw(deepCopy deepCmp has64bInt quad2Longs longs2Quad); @EXPORT_OK = @EXPORT; %EXPORT_TAGS = ( all => [@EXPORT_OK], ); use constant MAX32VAL => 0b11111111_11111111_11111111_11111111; use constant TEST32INT => 1 << 32; ##################################################################### # # Module code follows # ##################################################################### sub deepCopy (\[$@%]\[$@%]) { # Purpose: Attempts to safely copy an arbitrarily deep data # structure from the source to the target # Returns: True or False # Usage: $rv = deepCopy($source, $target); # Usage: $rv = deepCopy(@source, @target); # Usage: $rv = deepCopy(%source, %target); my $source = shift; my $target = shift; my $rv = 1; my $counter = 0; my $sref = defined $source ? ref $source : 'undef'; my $tref = defined $target ? ref $target : 'undef'; my ( @refs, $recurseSub ); subPreamble( PDLEVEL1, '$$', $source, $target ); croak 'source and target must be identical data types' unless ref $sref eq ref $tref; $recurseSub = sub { my $s = shift; my $t = shift; my $type = ref $s; my $irv = 1; my ( $key, $value ); # We'll grep the @refs list to make sure there's no # circular references going on if ( grep { $_ eq $s } @refs ) { Paranoid::ERROR = pdebug( 'Found a circular reference in data structure: ' . '(%s) %s', PDLEVEL1, $s, @refs ); return 0; } # Push the reference onto the list push @refs, $s; # Copy data over if ( $type eq 'ARRAY' ) { # Copy over array elements foreach my $element (@$s) { $type = ref $element; $counter++; if ( $type eq 'ARRAY' or $type eq 'HASH' ) { # Copy over sub arrays or hashes push @$t, $type eq 'ARRAY' ? [] : {}; return 0 unless &$recurseSub( $element, $$t[-1] ); } else { # Copy over everything else as-is push @$t, $element; } } } elsif ( $type eq 'HASH' ) { while ( ( $key, $value ) = each %$s ) { $type = ref $value; $counter++; if ( $type eq 'ARRAY' or $type eq 'HASH' ) { # Copy over sub arrays or hashes $$t{$key} = $type eq 'ARRAY' ? [] : {}; return 0 unless &$recurseSub( $value, $$t{$key} ); } else { # Copy over everything else as-is $$t{$key} = $value; } } } # We're done, so let's remove the reference we were working on pop @refs; return 1; }; # Start the copy if ( $sref eq 'ARRAY' or $sref eq 'HASH' ) { # Copy over arrays & hashes if ( $sref eq 'ARRAY' ) { @$target = (); } else { %$target = (); } $rv = &$recurseSub( $source, $target ); } else { # Copy over everything else directly $$target = $$source; $counter++; } $rv = $counter if $rv; subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub _cmpArray (\@\@) { # Purpose: Compares arrays, returns true if identical # Returns: Boolean # Usage: $rv = _cmpArray(@array1, @array2); my $ref1 = shift; my $ref2 = shift; my $rv = 1; my $i = 0; my ( $n, $d1, $d2, $t1, $t2 ); subPreamble( PDLEVEL2, '$$', $ref1, $ref2 ); $rv = scalar @$ref1 == scalar @$ref2; $n = scalar @$ref1; # Compare contents if there is any if ( $rv and $n ) { while ( $i <= $n ) { # Collect some meta data $d1 = defined $$ref1[$i]; $d2 = defined $$ref2[$i]; $t1 = $d1 ? ref $$ref1[$i] : 'undef'; $t2 = $d2 ? ref $$ref2[$i] : 'undef'; if ( $d1 == $d2 ) { # Both are undefined, so move to the next item unless ($d1) { $i++; next; } # Both are defined, so check for type $rv = $t1 eq $t2; if ($rv) { # The types are the same, so do some comparisons if ( $t1 eq 'ARRAY' ) { $rv = deepCmp( $$ref1[$i], $$ref2[$i] ); } elsif ( $t1 eq 'HASH' ) { $rv = deepCmp( $$ref1[$i], $$ref2[$i] ); } else { # Compare scalar value of all other types $rv = $$ref1[$i] eq $$ref2[$i]; } } } else { # One of the two are undefined, so quick exit $rv = 0; } # Early exit if we've found a difference already last unless $rv; # Otherwise, on to the next element $i++; } } # A little explicit sanitizing of input for false returns $rv = 0 unless $rv; subPostamble( PDLEVEL2, '$', $rv ); return $rv; } sub _cmpHash (\%\%) { # Purpose: Compares hashes, returns true if identical # Returns: Boolean # Usage: $rv = _cmpHash(%hash1, %hash2); my $ref1 = shift; my $ref2 = shift; my $rv = 1; my ( @k1, @k2, @v1, @v2 ); subPreamble( PDLEVEL2, '$$', $ref1, $ref2 ); @k1 = sort keys %$ref1; @k2 = sort keys %$ref2; # Compare first by key list $rv = _cmpArray( @k1, @k2 ); if ($rv) { # Compare by value list foreach (@k1) { push @v1, $$ref1{$_}; push @v2, $$ref2{$_}; } $rv = _cmpArray( @v1, @v2 ); } subPostamble( PDLEVEL2, '$', $rv ); return $rv; } sub deepCmp (\[$@%]\[$@%]) { # Purpose: Compares data structures, returns true if identical # Returns: Boolean # Usage: $rv = deepCmp(%hash1, %hash2); # Usage: $rv = deepCmp(@array1, @arrays2); my $ref1 = shift; my $ref2 = shift; my $rv = 1; subPreamble( PDLEVEL1, '$$', $ref1, $ref2 ); unless ( ref $ref1 eq ref $ref1 ) { $rv = 0; Paranoid::ERROR = pdebug( 'data structures are not the same type', PDLEVEL1 ); } if ( $rv and ref $ref1 eq 'SCALAR' ) { $rv = $ref1 eq $ref2; } elsif ( $rv and ref $ref1 eq 'ARRAY' ) { $rv = _cmpArray( @$ref1, @$ref2 ); } elsif ( $rv and ref $ref1 eq 'HASH' ) { $rv = _cmpHash( %$ref1, %$ref2 ); } else { $rv = 0; Paranoid::ERROR = pdebug( 'called with non-simple data types', PDLEVEL1 ); } subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub has64bInt { # Purpose: Returns whether the current platform supports 64b integers # Returns: Boolean # Usage: $rv = has64bInt(); return TEST32INT == 1 ? 0 : 1; } sub quad2Longs { # Purpose: Splits a quad into long integers # Returns: Array of Longs (low bytes, high bytes) # Usage: ($low, $high) = quad2Longs($quad); my $quad = shift; my ( $upper, $lower ); # Extract lower 32 bits $lower = $quad & MAX32VAL; # Extract upper 32 bits $upper = has64bInt() ? ( $quad & ~MAX32VAL ) >> 32 : 0; return ( $lower, $upper ); } sub longs2Quad { # Purpose: Joins two longs into a quad (if supported) # Returns: Quad Integer/undef # Usage: $quad = longs2Quad($low, $high); my $low = shift; my $high = shift; my $quad; if ( has64bInt() ) { $quad = $low | ( $high << 32 ); } else { $quad = $low if $high == 0; } return $quad; } 1; __END__ =head1 NAME Paranoid::Data - Misc. Data Manipulation Functions =head1 VERSION $Id: lib/Paranoid/Data.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ =head1 SYNOPSIS $rv = deepCopy($source, $target); $rv = deepCopy(@source, @target); $rv = deepCopy(%source, %target); $rv = deepCmp($source, $target); $rv = deepCmp(@source, @target); $rv = deepCmp(%source, %target); $rv = has64bInt(); ($low, $high) = quad2Longs($quad); $quad = longs2Quad($low, $high); =head1 DESCRIPTION This module provides data manipulation functions. =head1 IMPORT LISTS This module exports the following symbols by default: deepCopy deepCmp has64bInt The following specialized import lists also exist: List Members -------------------------------------------------------- all @defaults =head1 SUBROUTINES/METHODS =head2 deepCopy $rv = deepCopy($source, $target); $rv = deepCopy(@source, @target); $rv = deepCopy(%source, %target); This function performs a deep and safe copy of arbitrary data structures, checking for circular references along the way. Hashes and lists are safely duplicated while all other data types are just copied. This means that any embedded object references, etc., are identical in both the source and the target, which is probably not what you want. In short, this should only be used on pure hash/list/scalar value data structures. Both the source and the target data types must be of an identical type. This function returns the number of elements copied unless it runs into a problem (such as a circular reference), in which case it returns a zero. =head2 deepCmp $rv = deepCmp($source, $target); $rv = deepCmp(@source, @target); $rv = deepCmp(%source, %target); This function performs a deep comparison of arbitrarily complex data structures (i.e., hashes of lists of lists of scalars, etc.). It returns true if the values of the structures are identical, false otherwise. Like the B function there are no provisions for evaluating objects beyond what their values are when coerced as scalar types. End sum, the same caveats that applied to B apply here. =head2 has64bInt $rv = has64bInt(); This function returns a boolean value denoting whether the platform has native 64bit integers or not. =head2 quad2Longs ($low, $high) = quad2Longs($quad); This function takes any 64bit integer and splits it into two native longs, in the order of low order long, high order long. This function will still work on platforms that don't support native quads. In that case, it will just be assumed that the high order bytes equal zero. =head2 longs2Quad $quad = longs2Quad($low, $high); This function takes two longs and combines them into a single native quad. This function will still work on platforms without native quad support, but only if the value of the quad is small enough to fit into a long, which is what's actually returned in that scenario. In the case of the high order bytes are not zero on a platform without native quad support, this function will return undef. =head1 DEPENDENCIES =over =item o L =item o L =item o L =back =head1 BUGS AND LIMITATIONS =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is free software. Similar to Perl, you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation ; either version 1 , or any later version , or b) the Artistic License 2.0 , subject to the following additional term: No trademark rights to "Paranoid" have been or are conveyed under any of the above licenses. However, "Paranoid" may be used fairly to describe this unmodified software, in good faith, but not as a trademark. (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com) (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com) Paranoid-2.10/lib/Paranoid/IO/0000750000175000001440000000000014211616225015534 5ustar acorlissusersParanoid-2.10/lib/Paranoid/IO/FileMultiplexer/0000750000175000001440000000000014211616225020646 5ustar acorlissusersParanoid-2.10/lib/Paranoid/IO/FileMultiplexer/Block/0000750000175000001440000000000014211616225021700 5ustar acorlissusersParanoid-2.10/lib/Paranoid/IO/FileMultiplexer/Block/FileHeader.pm0000644000175000001440000005304514211615520024237 0ustar acorlissusers# Paranoid::IO::FileMultiplexer::Block::FileHeader -- File Header Block # # $Id: lib/Paranoid/IO/FileMultiplexer/Block/FileHeader.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ # # This software is free software. Similar to Perl, you can redistribute it # and/or modify it under the terms of either: # # a) the GNU General Public License # as published by the # Free Software Foundation ; either version 1 # , or any later version # , or # b) the Artistic License 2.0 # , # # subject to the following additional term: No trademark rights to # "Paranoid" have been or are conveyed under any of the above licenses. # However, "Paranoid" may be used fairly to describe this unmodified # software, in good faith, but not as a trademark. # # (c) 2005 - 2021, Arthur Corliss (corliss@digitalmages.com) # (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com) # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::IO::FileMultiplexer::Block::FileHeader; use 5.008; use strict; use warnings; use vars qw($VERSION); use base qw(Exporter); use Paranoid qw(:all); use Paranoid::IO qw(:all); use Paranoid::Debug qw(:all); use Paranoid::Data; use Fcntl qw(:DEFAULT :flock :mode :seek); use Paranoid::IO::FileMultiplexer::Block; use Paranoid::IO::FileMultiplexer::Block::StreamHeader; use Paranoid::IO::FileMultiplexer::Block::BATHeader; ($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm ); use base qw(Paranoid::IO::FileMultiplexer::Block); use constant PIOFMVER => '1.0'; # Signature format: # PIOFM VER BS BC # Z6 Z4 NNx NNx # 28 bytes # # Stream record format: # String BN # Z21 NNx # 30 bytes use constant SIGNATURE => 'Z6Z4NNxNNx'; use constant SIG_LEN => 28; use constant SIG_TYPE => 'PIOFM'; use constant BLOCKS_POS => 10; use constant BLOCKC_POS => 19; use constant STREAMS_POS => 28; use constant STRMIDX => 'Z21NNx'; use constant STRM_LEN => 30; ##################################################################### # # Module code follows # ##################################################################### sub new { # Purpose: Creates a new file header object # Returns: Object reference/undef # Usage: $obj = # Paranoid::IO::FileMultiplexer::Block::FileHeader->new($file, $blockSize); my $class = shift; my $file = shift; my $bsize = shift; my $self; subPreamble( PDLEVEL3, '$$', $file, $bsize ); $self = __PACKAGE__->SUPER::new( $file, 0, $bsize ); if ( defined $self ) { $$self{version} = PIOFMVER; $$self{blocks} = 1; $$self{streamidx} = {}; # name => idx of rec in streams $$self{streams} = []; # array of [ name, blockNum ] $$self{maxStreams} = int( ( $bsize - SIG_LEN ) / STRM_LEN ); } subPostamble( PDLEVEL3, '$', $self ); return $self; } sub blocks { # Purpose: Returns the number of blocks recorded in the signature # Returns: Integer # Usage: $count = $obj->blocks; my $self = shift; return $$self{blocks}; } sub version { # Purpose: Returns the version of the file format # Returns: String # Usage: $ver = $obj->version; my $self = shift; return $$self{version}; } sub streams { # Purpose: Returns a hash of stream names => blockNums # Returns: Hash # Usage: %streams = $obj->streams; my $self = shift; my @streams = @{ $$self{streams} }; my ( %rv, $stream ); foreach $stream (@streams) { $rv{ $$stream[0] } = $$stream[1]; } return %rv; } sub maxStreams { # Purpose: Returns the maximum number of streams supported by this file # Returns: Integer # Usage: $max = $obj->maxStreams; my $self = shift; return $$self{maxStreams}; } sub _transHuman { # Purpose: Translates raw integers into human-readable values # Returns: String # Usage: $rv = _transHuman($n); my $n = shift; my $u = 'B'; while ( $n > 1024 ) { $u = $u eq 'B' ? 'KB' : $u eq 'KB' ? 'MB' : $u eq 'MB' ? 'GB' : $u eq 'GB' ? 'TB' : $u eq 'TB' ? 'PB' : 'EX'; $n /= 1024; last if $u eq 'EX'; } $n = sprintf( '%0.2f', $n ); return "$n$u"; } sub model { # Purpose: Returns a hash of file statistics # Returns: Hash # Usage: $stats = $obj->model; my $self = shift; my $bs = $$self{blockSize}; my $blks = $$self{blocks}; my $strms = scalar keys %{ $$self{streamidx} }; my ( $block, $maxBATs, $maxData, %rv ); # Get reference max values $block = Paranoid::IO::FileMultiplexer::Block::StreamHeader->new( $$self{file}, 1, $bs, 'foo' ); $maxBATs = $block->maxBATs; $block = Paranoid::IO::FileMultiplexer::Block::BATHeader->new( $$self{file}, 1, $bs, 'foo', 0 ); $maxData = $block->maxData; # Current stats $rv{intSize} = ( 1 << 32 ) == 1 ? 32 : 64; $rv{curFileSize} = $bs * $blks; $rv{curFSHuman} = _transHuman( $rv{curFileSize} ); $rv{curStreams} = $strms; # Predicted max $rv{maxFileSize} = 0b11111111_11111111_11111111_11111111; $rv{maxFileSize} = $rv{maxFileSize} | ( $rv{maxFileSize} << 32 ) if $rv{intSize} == 64; $rv{maxStreams} = $$self{maxStreams}; $rv{maxStreamSize} = $bs * $maxBATs * $maxData; $rv{maxStreamSize} = $rv{maxFileSize} if $rv{maxStreamSize} > $rv{maxFileSize}; $rv{maxSSHuman} = _transHuman( $rv{maxStreamSize} ); # Provide human-readable values $rv{maxFSHuman} = _transHuman( $rv{maxFileSize} ); return %rv; } sub writeSig { # Purpose: Writes the file signature to the file # Returns: Boolean # Usage: $rv = $obj->writeSig; my $self = shift; my $file = $$self{file}; my $ver = $$self{version}; my $rv = 0; my $sig = pack SIGNATURE, SIG_TYPE, PIOFMVER, quad2Longs( $$self{blockSize} ), quad2Longs( $$self{blocks} ); pdebug( 'entering', PDLEVEL3 ); pIn(); $rv = $self->bwrite($sig); pOut(); pdebug( 'leaving w/rv: %s', PDLEVEL3, $rv ); return $rv; } sub readSig { # Purpose: Reads the block signature from the file # Returns: Boolean # Usage: $rv = $obj->readSig; my $self = shift; my $file = $$self{file}; my $rv = 0; my ( $raw, $type, $ver, $bs, $bc, $tblock ); my ( $lbs, $ubs, $lbc, $ubc ); subPreamble(PDLEVEL3); if ( pflock( $file, LOCK_SH ) ) { if ( $self->bread( \$raw, 0, SIG_LEN ) == SIG_LEN ) { $rv = 1; # Unpack the signature ( $type, $ver, $lbs, $ubs, $lbc, $ubc ) = unpack SIGNATURE, $raw; # Validate contents # # Start with file type unless ( $type eq SIG_TYPE ) { $rv = 0; pdebug( 'Invalid file header type (%s)', PDLEVEL1, $type ); } # format version unless ( $ver eq PIOFMVER ) { $rv = 0; pdebug( 'Invalid file header version (%s)', PDLEVEL1, $ver ); } # Make sure block size is legitimate $bs = longs2Quad( $lbs, $ubs ); if ( defined $bs ) { $tblock = __PACKAGE__->new( $file, $bs ); unless ( defined $tblock ) { $rv = 0; pdebug( 'blockSize error in file header: %s', PDLEVEL1, $bs ); } } else { pdebug( 'this platform does not support 64b values for block size', PDLEVEL1 ); $rv = 0; } # Validate end of file matches block count $bc = longs2Quad( $lbc, $ubc ); if ( defined $bc ) { pseek( $file, 0, SEEK_END ); unless ( ptell($file) == $bc * $bs ) { $rv = 0; pdebug( 'incorrect file size based on block count (%s * %s = %s)', PDLEVEL1, $bc, $bs, $bc * $bs ); } } else { pdebug( 'this platform does not support 64b values for block count', PDLEVEL1 ); $rv = 0; } # Update internal values if ($rv) { $$self{version} = $ver; $$self{blockSize} = $bs; $$self{blocks} = $bc; $self->recalibrate; } else { pdebug( 'file signature verification failure', PDLEVEL1 ); } } else { pdebug( 'failed to read file header signature', PDLEVEL1 ); } pflock( $file, LOCK_UN ); } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub writeBlocks { # Purpose: Updates the blocks counter and writes it to disk # Returns: Boolean # Usage: $rv = $obj->writeBlocks($count); my $self = shift; my $bcount = shift; my ( $raw, $rv ); subPreamble( PDLEVEL3, '$', $bcount ); if ( defined $bcount and $bcount > 0 ) { $raw = pack 'NN', quad2Longs($bcount); if ( $self->bwrite( $raw, BLOCKC_POS ) == 8 ) { $$self{blocks} = $bcount; $rv = 1; } } else { pdebug( 'invalid value for blocks (%s)', PDLEVEL1, $bcount ); } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub readBlocks { # Purpose: Reads the blocks counter from disk # Returns: Integer/undef on error # Usage: $count = $obj->readBlocks; my $self = shift; my ( $rv, $raw ); subPreamble(PDLEVEL3); if ( $self->bread( \$raw, BLOCKC_POS, 8 ) == 8 ) { $rv = longs2Quad( unpack 'NN', $raw ); $rv = PTRUE_ZERO if defined $rv and $rv == 0; } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub incrBlocks { # Purpose: Increments the block count and writes the field to disk # Returns: Boolean # Usage: $rv = $obj->incrBlocks; my $self = shift; return $self->writeBlocks( $$self{blocks} + 1 ); } sub validateBlocks { # Purpose: Compares in-memory block counter to what's stored in the file # Returns: Boolean # Usage: $rv = $obj->validateBlocks; my $self = shift; my $rv = 0; subPreamble(PDLEVEL3); $rv = 1 if $$self{blocks} == $self->readBlocks; subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub writeStreams { # Purpose: Writes all the stream index records to the file # Returns: Boolean # Usage: $rv = $obj->writeStreams; my $self = shift; my $file = $$self{file}; my $rv = 0; my ( $rec, $i, $pos ); subPreamble(PDLEVEL3); # Hold an exclusive lock for the entire transaction if ( pflock( $file, LOCK_EX ) ) { $rv = 1; $i = 0; foreach $rec ( @{ $$self{streams} } ) { @$rec = ( $$rec[0], quad2Longs( $$rec[1] ) ); $pos = STREAMS_POS + $i * STRM_LEN; $rv = 0 unless $self->bwrite( pack( STRMIDX, @$rec ), $pos ) == STRM_LEN; $i++; last unless $rv; } pflock( $file, LOCK_UN ); } pdebug( 'failed to write all stream records to the file header', PDLEVEL1 ) unless $rv; subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub readStreams { # Purpose: Reads the stream records from the file header # Returns: Boolean # Usage: $rv = $obj->readStreams; my $self = shift; my $rv = 1; my ( $raw, $sname, $bn, @sraw, $prev ); my ( %sidx, @streams, %model, $maxstreams ); subPreamble(PDLEVEL3); # Read the streams section of the block if ( $self->bread( \$raw, STREAMS_POS ) ) { # Get the model so we know how many streams we can support %model = $self->model; $maxstreams = $model{maxStreams}; @sraw = unpack '(' . STRMIDX . ")$maxstreams", $raw; while (@sraw) { $sname = shift @sraw; $bn = longs2Quad( shift @sraw, shift @sraw ); # Stop processing when it looks like we're not getting legitmate # values last unless defined $sname and length $sname and $bn > 0; # Make sure we're not getting repeated streams if ( exists $sidx{$sname} ) { pdebug( 'stream (%s) listed more than once', PDLEVEL1, $sname ); $rv = 0; last; } # Error out if stream block numbers aren't ascending unless ( !defined $prev or $bn > $prev ) { pdebug( 'stream block number appearing out of sequence', PDLEVEL1 ); $rv = 0; last; } # Save entry push @streams, [ $sname, $bn ]; $sidx{$sname} = $#streams; $prev = $bn; } # Save everything extracted $$self{streamidx} = {%sidx}; $$self{streams} = [@streams]; pdebug( 'found %s streams', PDLEVEL4, scalar @streams ); } else { pdebug( 'failed to read list of streams from file header', PDLEVEL1 ); $rv = 0; } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub addStream { # Purpose: Adds a stream record to the file header # Returns: Boolean # Usage: $rv = $obj->addStream($sname, $bn); my $self = shift; my $sname = shift; my $bn = shift; my %sidx = %{ $$self{streamidx} }; my $rv = 1; subPreamble( PDLEVEL3, '$$', $sname, $bn ); if ( defined $sname and length $sname ) { if ( exists $sidx{$sname} ) { pdebug( 'stream already exists (%s)', PDLEVEL1, $sname ); $rv = 0; } if ( length $sname > 20 ) { pdebug( 'stream name is too long (%s)', PDLEVEL1, $sname ); $rv = 0; } if ( !defined $bn or $bn < 1 ) { pdebug( 'invalid stream block number (%s)', PDLEVEL1, $bn ); $rv = 0; } if ($rv) { push @{ $$self{streams} }, [ $sname, $bn ]; ${ $$self{streamidx} }{$sname} = $#{ $$self{streams} }; $rv = 0 unless $self->bwrite( pack( STRMIDX, $sname, $bn ), STREAMS_POS + STRM_LEN * $#{ $$self{streams} } ) == STRM_LEN; } } else { pdebug( 'invalid stream name (%s)', PDLEVEL1, $sname ); $rv = 0; } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } 1; __END__ =head1 NAME Paranoid::IO::FileMultiplexer::Block::FileHeader - File Header Block =head1 VERSION $Id: lib/Paranoid/IO/FileMultiplexer/Block/FileHeader.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ =head1 SYNOPSIS $obj = Paranoid::IO::FileMultiplexer::Block::FileHeader->new( $filename, $bsize); $count = $obj->blocks; $version = $obj->version; %streams = $obj->streams; $max = $obj->maxStreams; %model = $obj->model; $rv = $obj->writeSig; $rv = $obj->readSig; $rv = $obj->writeBlocks; $count = $obj->readBlocks; $rv = $obj->incrBlocks; $rv = $obj->validateBlocks; $rv = $obj->writeStreams; $rv = $obj->readStreams; $rv = $obj->addStream($sname, $bn); =head1 DESCRIPTION This class is not meant to be used directly, but as part of the L functionality. This provides functionality necessary for manipulation of the file header block. This module does presume that whatever file it is being used on has already been opened in the appropriate mode, and that the L flock stack has been enabled. For the purposes of L, this is done in that class. =head1 SUBROUTINES/METHODS =head2 new $obj = Paranoid::IO::FileMultiplexer::Block::FileHeader->new($file, $blockSize); This creates a new instance of a file header block object. It requires the filename in order to retrieve the cached file handle from L, and the size of the block. This always writes to the first block of the file. B creating an object does not automatically create the file and/or write a signature. That must be done using the methods below. =head2 blocks $count = $obj->blocks; This method returns the value of the blocks field in the file header. This is the total number of blocks allocated in the file to date. Note that this is only the cached value stored in the object. Other methods are provided for writing and reading the value from the file. =head2 version $ver = $obj->version; This method returns the file format version as a string. =head2 streams %streams = $obj->streams; This method returns a hash of streams allocated in the file, in the format of I => I. =head2 maxStreams $max = $obj->maxStreams; This method returns the maximum number of streams supported by this file header. =head2 model $stats = $obj->model; This method returns a hash with some basic statistical information on the file, in both raw and human-friendly values. The information provided is as follows: Key Description --------------------------------------------------------------- intSize Size of Perl's native integers in bits curFileSize Current file size in bytes curFSHuman Current file size expressed w/unit suffixes curStreams Current number of streams allocated maxFileSize Maximum file size supported with Perl maxFSHuman Maximum file size expressed w/unit suffixes maxStreams Maximum number of streams that can be allocated maxStreamSize Maximum stream size maxSSHuman Maximum stream size expressed w/unit suffixes =head2 writeSig $rv = $obj->writeSig; This method writes the file header signature to disk, returning a boolean value denoting its success. Note that the signature contains the file format, version, block size, and number of allocated blocks, but not the list of allocated streams. =head2 readSig $rv = $obj->readSig; This method reads the file header signature from disk and performs basic validation that the information in it is acceptable. It validates that the file size matches the block size * block count, that the block size is an acceptable value, and the file format and version are supported. If the method call was successful it will update the cached values in the object. Note that this is only the signature values, not the stream index records. =head2 writeBlocks $rv = $obj->writeBlocks($count); This method writes the passed block count value to disk, and returns a boolean value denoting success. =head2 readBlocks $count = $obj->readBlocks; This method reads the block count field from disk and returns it. If there are any errors reading or extracting the value, it will return undef. =head2 incrBlocks $rv = $obj->incrBlocks; This method calls L with a value of one greater that what's currently cached. =head2 validateBlocks $rv = $obj->validateBlocks; This method compares the cached block count value to what's actually written in the file. This is useful for determining whether an external process has potentially modified the file. =head2 writeStreams $rv = $obj->writeStreams; This method writes the stream index records to the header block, and returns a boolean denoting success. =head2 readStreams $rv = $obj->readStreams; This method reads the stream index records from the file, and returns a boolean value denoting success. If the read is successful, this will update the cached streams information in the object. =head2 addStream $rv = $obj->addStream($sname, $bn); This method does some basic validation of the requested stream, and if it passes, updates the stream indices on the disk. =head1 DEPENDENCIES =over =item o L =item o L =item o L =item o L =item o L =item o L =item o L =item o L =back =head1 BUGS AND LIMITATIONS =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is free software. Similar to Perl, you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation ; either version 1 , or any later version , or b) the Artistic License 2.0 , subject to the following additional term: No trademark rights to "Paranoid" have been or are conveyed under any of the above licenses. However, "Paranoid" may be used fairly to describe this unmodified software, in good faith, but not as a trademark. (c) 2005 - 2021, Arthur Corliss (corliss@digitalmages.com) (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com) Paranoid-2.10/lib/Paranoid/IO/FileMultiplexer/Block/StreamHeader.pm0000644000175000001440000004042514211615520024611 0ustar acorlissusers# Paranoid::IO::FileMultiplexer::Block::StreamHeader -- Stream Header Block # # $Id: lib/Paranoid/IO/FileMultiplexer/Block/StreamHeader.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ # # This software is free software. Similar to Perl, you can redistribute it # and/or modify it under the terms of either: # # a) the GNU General Public License # as published by the # Free Software Foundation ; either version 1 # , or any later version # , or # b) the Artistic License 2.0 # , # # subject to the following additional term: No trademark rights to # "Paranoid" have been or are conveyed under any of the above licenses. # However, "Paranoid" may be used fairly to describe this unmodified # software, in good faith, but not as a trademark. # # (c) 2005 - 2021, Arthur Corliss (corliss@digitalmages.com) # (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com) # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::IO::FileMultiplexer::Block::StreamHeader; use 5.008; use strict; use warnings; use vars qw($VERSION); use base qw(Exporter); use Paranoid qw(:all); use Paranoid::IO qw(:all); use Paranoid::Debug qw(:all); use Paranoid::Data; use Fcntl qw(:DEFAULT :flock :mode :seek); ($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm ); use base qw(Paranoid::IO::FileMultiplexer::Block); # Signature format: # PIOFMSTRM Name EOS # Z10 Z21 NNx # 40 bytes # # BAT record format: # BlockNum # NN # 8 bytes use constant SIGNATURE => 'Z10Z21NNx'; use constant SIG_LEN => 40; use constant SIG_TYPE => 'PIOFMSTRM'; use constant EOS_POS => 31; use constant BATS_POS => 40; use constant BATIDX => 'NN'; use constant BAT_LEN => 8; ##################################################################### # # Module code follows # ##################################################################### sub new { # Purpose: Creates a new stream header object # Returns: Object reference/undef # Usage: $obj = # Paranoid::IO::FileMultiplexer::Block::StreamHeader->new($file, # $blockNo, $blockSize, $strmName); my $class = shift; my $file = shift; my $bnum = shift; my $bsize = shift; my $sname = shift; my $self; subPreamble( PDLEVEL3, '$$$$', $file, $bnum, $bsize, $sname ); if ( defined $sname and length $sname and length $sname <= 20 ) { $self = __PACKAGE__->SUPER::new( $file, $bnum, $bsize ); } else { pdebug( 'invalid stream name (%s)', PDLEVEL1, $sname ); } if ( defined $self ) { $$self{streamName} = $sname; $$self{bats} = []; # array of blockNum $$self{eos} = 0; # address of stream EOF $$self{maxBATs} = int( ( $$self{blockSize} - SIG_LEN ) / BAT_LEN ); } subPostamble( PDLEVEL3, '$', $self ); return $self; } sub streamName { # Purpose: Returns the current stream name # Returns: String # Usage: $name = $obj->streamName; my $self = shift; return $$self{streamName}; } sub maxBATs { # Purpose: Returns the max BAT blocks for the stream # Returns: Integer # Usage: $max = $obj->maxBATs; my $self = shift; return $$self{maxBATs}; } sub eos { # Purpose: Returns the current stream EOS # Returns: Integer # Usage: $eos = $obj->eos; my $self = shift; return $$self{eos}; } sub bats { # Purpose: Returns an array of bat nums # Returns: Hash # Usage: @bats = $obj->bats; my $self = shift; return @{ $$self{bats} }; } sub full { # Purpose: Returns whether the streams's array of BAT blocks is full # Returns: Boolean # Usage: $rv = $obj->full; my $self = shift; return $self->maxBATs == scalar $self->bats; } sub writeSig { # Purpose: Writes the stream signature to the file # Returns: Boolean # Usage: $rv = $obj->writeSig; my $self = shift; my $file = $$self{file}; my $sname = $$self{streamName}; my $eos = $$self{eos}; my $rv = 0; my $sig = pack SIGNATURE, SIG_TYPE, $sname, quad2Longs($eos); subPreamble(PDLEVEL3); $rv = $self->bwrite($sig); subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub readSig { # Purpose: Reads the block signature from the file # Returns: Boolean # Usage: $rv = $obj->readSig; my $self = shift; my $file = $$self{file}; my $rv = 0; my ( $raw, $type, $sname, $eos, $leos, $ueos ); subPreamble(PDLEVEL3); if ( pflock( $file, LOCK_SH ) ) { if ( $self->bread( \$raw, 0, SIG_LEN ) == SIG_LEN ) { $rv = 1; # Unpack the signature ( $type, $sname, $leos, $ueos ) = unpack SIGNATURE, $raw; # Validate contents # # Start with file type unless ( $type eq SIG_TYPE ) { $rv = 0; pdebug( 'Invalid stream header type (%s)', PDLEVEL1, $type ); } # stream name unless ( $sname eq $$self{streamName} ) { $rv = 0; pdebug( 'Invalid stream name (%s)', PDLEVEL1, $sname ); } # Make sure eos is legitimate $eos = longs2Quad( $leos, $ueos ); unless ( defined $eos ) { pdebug( 'this platform does not support 64b values for eos', PDLEVEL1 ); $rv = 0; } # Update internal values if ($rv) { $$self{eos} = $eos; } else { pdebug( 'stream signature verification failure', PDLEVEL1 ); } } else { pdebug( 'failed to read stream header signature', PDLEVEL1 ); } pflock( $file, LOCK_UN ); } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub writeEOS { # Purpose: Updates the EOS counter and writes it to disk # Returns: Boolean # Usage: $rv = $obj->writeEOS($pos); my $self = shift; my $eos = shift; my ( $raw, $rv ); subPreamble( PDLEVEL3, '$', $eos ); if ( defined $eos ) { $raw = pack 'NN', quad2Longs($eos); if ( $self->bwrite( $raw, EOS_POS ) == 8 ) { $$self{eos} = $eos; $rv = 1; } } else { pdebug( 'invalid value for eos (%s)', PDLEVEL1, $eos ); } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub readEOS { # Purpose: Reads the EOS counter from disk # Returns: Integer/undef on error # Usage: $pos = $obj->readEOS; my $self = shift; my ( $rv, $raw ); subPreamble(PDLEVEL3); if ( $self->bread( \$raw, EOS_POS, 8 ) == 8 ) { $rv = longs2Quad( unpack 'NN', $raw ); $rv = PTRUE_ZERO if defined $rv and $rv == 0; } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub validateEOS { # Purpose: Compares in-memory EOS counter to what's stored in the file # Returns: Boolean # Usage: $rv = $obj->validateBlocks; my $self = shift; my $rv = 0; subPreamble(PDLEVEL3); $rv = 1 if $$self{eos} == $self->readEOS; subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub writeBATs { # Purpose: Writes all the BAT block numbers to the file # Returns: Boolean # Usage: $rv = $obj->writeBATs; my $self = shift; my $file = $$self{file}; my $rv = 0; my ( $rec, $i, $pos ); subPreamble(PDLEVEL3); # Hold an exclusive lock for the entire transaction if ( pflock( $file, LOCK_EX ) ) { $rv = 1; $i = 0; foreach $rec ( @{ $$self{bats} } ) { $pos = BATS_POS + $i * BAT_LEN; $rv = 0 unless $self->bwrite( pack( BATIDX, quad2Longs($rec) ), $pos ) == BAT_LEN; $i++; last unless $rv; } pflock( $file, LOCK_UN ); } pdebug( 'failed to write all BAT block numbers to the stream header', PDLEVEL1 ) unless $rv; subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub readBATs { # Purpose: Reads the BAT records from the stream header # Returns: Boolean # Usage: $rv = $obj->readBATs; my $self = shift; my $rv = 1; my ( $raw, @sraw, $bn, $lbn, $ubn, $prev ); my @bats; subPreamble(PDLEVEL3); # Read the BATs section of the block if ( $self->bread( \$raw, BATS_POS ) ) { @sraw = unpack '(' . BATIDX . ")$$self{maxBATs}", $raw; while (@sraw) { $lbn = shift @sraw; $ubn = shift @sraw; $bn = longs2Quad( $lbn, $ubn ); # Stop processing when it looks like we're not getting legitmate # values last unless defined $bn and $bn > $$self{blockNum}; # Error out if block numbers aren't ascending unless ( !defined $prev or $bn > $prev ) { pdebug( 'BAT block number appearing out of sequence', PDLEVEL1 ); $rv = 0; last; } # Save entry push @bats, $bn; $prev = $bn; } # Save everything extracted $$self{bats} = [@bats]; pdebug( 'found %s bats', PDLEVEL4, scalar @bats ); } else { pdebug( 'failed to read list of BATs from stream header', PDLEVEL1 ); $rv = 0; } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub addBAT { # Purpose: Adds a BAT block number to the stream header # Returns: Boolean # Usage: $rv = $obj->addBAT($bn); my $self = shift; my $bn = shift; my $rv = 1; subPreamble( PDLEVEL3, '$', $bn ); if ( defined $bn and $bn > $$self{blockNum} ) { # Make sure we're not adding redundant entries if ( scalar grep { $_ eq $bn } @{ $$self{bats} } ) { $rv = 0; pdebug( 'redundant entry for an existing BAT', PDLEVEL1 ); } # Make sure new BAT is a higher block number than all previous BATs if ( scalar grep { $_ > $bn } @{ $$self{bats} } ) { $rv = 0; pdebug( 'BAT block number is lower than previous BATs', PDLEVEL1 ); } if ($rv) { push @{ $$self{bats} }, $bn; $rv = 0 unless $self->bwrite( pack( BATIDX, quad2Longs($bn) ), BATS_POS + BAT_LEN * $#{ $$self{bats} } ) == BAT_LEN; } } else { pdebug( 'invalid BAT block number (%s)', PDLEVEL1, $bn ); $rv = 0; } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } 1; __END__ =head1 NAME Paranoid::IO::FileMultiplexer::Block::StreamHeader - Stream Header Block =head1 VERSION $Id: lib/Paranoid/IO/FileMultiplexer/Block/StreamHeader.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ =head1 SYNOPSIS $obj = Paranoid::IO::FileMultiplexer::Block::StreamHeader->new($file, $blockNo, $blockSize, $strmName); $name = $obj->streamName; $max = $obj->maxBATs; $eos = $obj->eos; @bats = $obj->bats; $rv = $obj->full; $rv = $obj->writeSig; $rv = $obj->readSig; $rv = $obj->writeEOS($pos); $pos = $obj->readEOS; $rv = $obj->validateBlocks; $rv = $obj->writeBATs; $rv = $obj->readBATs; $rv = $obj->addBAT($bn); =head1 DESCRIPTION This class is not meant to be used directly, but as part of the L functionality. This provides functionality necessary for manipulation of the stream header block. This module does presume that whatever file it is being used on has already been opened in the appropriate mode, and that the L flock stack has been enabled. For the purposes of L, this is done in that class. =head1 SUBROUTINES/METHODS =head2 new $obj = Paranoid::IO::FileMultiplexer::Block::StreamHeader->new($file, $blockNo, $blockSize, $strmName); This creates a new instance of a stream header block object. It requires the filename in order to retrieve the cached file handle from L, the block number of the block, the size of the block, and the name of the stream. B creating an object does not automatically create the file and/or write a signature. That must be done using the methods below. =head2 streamName $name = $obj->streamName; This method returns the stream name. =head2 maxBATs $max = $obj->maxBATs; This method returns the maximum number of BATs supported by the stream. =head2 eos $eos = $obj->eos; This method returns the current EOS of the stream. Note that this is just the last cached value, which may be out of sync with the contents of the file. =head2 bats %bats = $obj->bats; This method returns an array of BAT block numbers allocated to the stream. =head2 full $rv = $obj->full; This method returns a boolean value denoting whether this streams's array of BAT blocks is at maximum capacity or not. =head2 writeSig $rv = $obj->writeSig; This method writes the stream header signature to disk, returning a boolean value denoting its success. Note that the signature contains the file format, stream name, and current EOS position. This does not include the allocated BAT block numbers. =head2 readSig $rv = $obj->readSig; This method reads the stream header signature from disk and performs basic validation that the information in it is acceptable. It validates that the stream name matches what is expected and the block format is correct. If the method call was successful it will update the cached values in the object. Note that this is only the signature values, not the BAT block numbers. =head2 writeEOS $rv = $obj->writeEOS($pos); This method writes the passed stream EOS position to disk, and returns a boolean value denoting success. =head2 readEOS $pos = $obj->readEOS; This method reads the stream EOS postiong from disk and returns it. If there are any errors reading or extracting the value, it will return undef. =head2 validateEOS $rv = $obj->validateEOS; This method compares the cached EOS position to what's actually written in the file. This is useful for determining whether an external process has potentially modified the file. =head2 writeBATs $rv = $obj->writeBATs; This method writes the BAT block numbers to the header block, and returns a boolean denoting success. =head2 readBATs $rv = $obj->readBATs; This method reads the BAT block numbers from the file, and returns a boolean value denoting success. If the read is successful, this will update the cached BATs in the object. =head2 addBAT $rv = $obj->addBAT($bn); This method does some basic validation of the requested BAT, and if it passes, updates the BAT block number list on the disk. =head1 DEPENDENCIES =over =item o L =item o L =item o L =item o L =item o L =item o L =back =head1 BUGS AND LIMITATIONS =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is free software. Similar to Perl, you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation ; either version 1 , or any later version , or b) the Artistic License 2.0 , subject to the following additional term: No trademark rights to "Paranoid" have been or are conveyed under any of the above licenses. However, "Paranoid" may be used fairly to describe this unmodified software, in good faith, but not as a trademark. (c) 2005 - 2021, Arthur Corliss (corliss@digitalmages.com) (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com) Paranoid-2.10/lib/Paranoid/IO/FileMultiplexer/Block/BATHeader.pm0000644000175000001440000003456014211615520023767 0ustar acorlissusers# Paranoid::IO::FileMultiplexer::Block::BATHeader -- BAT Header Block # # $Id: lib/Paranoid/IO/FileMultiplexer/Block/BATHeader.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ # # This software is free software. Similar to Perl, you can redistribute it # and/or modify it under the terms of either: # # a) the GNU General Public License # as published by the # Free Software Foundation ; either version 1 # , or any later version # , or # b) the Artistic License 2.0 # , # # subject to the following additional term: No trademark rights to # "Paranoid" have been or are conveyed under any of the above licenses. # However, "Paranoid" may be used fairly to describe this unmodified # software, in good faith, but not as a trademark. # # (c) 2005 - 2021, Arthur Corliss (corliss@digitalmages.com) # (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com) # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::IO::FileMultiplexer::Block::BATHeader; use 5.008; use strict; use warnings; use vars qw($VERSION); use base qw(Exporter); use Paranoid; use Paranoid::IO qw(:all); use Paranoid::Debug qw(:all); use Paranoid::Data; use Fcntl qw(:DEFAULT :flock :mode :seek); ($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm ); use base qw(Paranoid::IO::FileMultiplexer::Block); # Signature format: # PIOFMBAT Name Sequence # Z9 Z21 NNxx # 40 bytes # # Data record format: # BlockNum # NN # 8 bytes use constant SIGNATURE => 'Z9Z21NNxx'; use constant SIG_LEN => 40; use constant SIG_TYPE => 'PIOFMBAT'; use constant SEQ_POS => 30; use constant DATA_POS => 40; use constant DATAIDX => 'NN'; use constant DATA_LEN => 8; ##################################################################### # # Module code follows # ##################################################################### sub new { # Purpose: Creates a new BAT header object # Returns: Object reference/undef # Usage: $obj = # Paranoid::IO::FileMultiplexer::Block::BATHeader->new($file, # $blockNo, $blockSize, $strmName, $sequenceNo); my $class = shift; my $file = shift; my $bnum = shift; my $bsize = shift; my $sname = shift; my $seq = shift; my $self; subPreamble( PDLEVEL3, '$$$$$', $file, $bnum, $bsize, $sname, $seq ); $self = __PACKAGE__->SUPER::new( $file, $bnum, $bsize ); if ( defined $self ) { $$self{streamName} = $sname; $$self{data} = []; # array of data blockNums $$self{sequence} = 0; # sequence no of BAT $$self{maxData} = int( ( $$self{blockSize} - SIG_LEN ) / DATA_LEN ); } subPostamble( PDLEVEL3, '$', $self ); return $self; } sub maxData { # Purpose: Returns the max data blocks for the BAT # Returns: Integer # Usage: $max = $obj->maxData; my $self = shift; return $$self{maxData}; } sub sequence { # Purpose: Returns the current BAT sequence number # Returns: Integer # Usage: $seq = $obj->sequence; my $self = shift; return $$self{sequence}; } sub dataBlocks { # Purpose: Returns an array of data block nums # Returns: Array # Usage: @data = $obj->dataBlocks; my $self = shift; return @{ $$self{data} }; } sub full { # Purpose: Returns whether the BAT's array of data blocks is full # Returns: Boolean # Usage: $rv = $obj->full; my $self = shift; return $self->maxData == scalar $self->dataBlocks; } sub writeSig { # Purpose: Writes the BAT signature to the file # Returns: Boolean # Usage: $rv = $obj->writeSig; my $self = shift; my $file = $$self{file}; my $sname = $$self{streamName}; my $seq = $$self{sequence}; my $rv = 0; my $sig = pack SIGNATURE, SIG_TYPE, $sname, quad2Longs($seq); subPreamble(PDLEVEL3); $rv = $self->bwrite($sig); subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub readSig { # Purpose: Reads the block signature from the file # Returns: Boolean # Usage: $rv = $obj->readSig; my $self = shift; my $file = $$self{file}; my $rv = 0; my ( $raw, $type, $sname, $seq, $lseq, $useq ); subPreamble(PDLEVEL3); if ( pflock( $file, LOCK_SH ) ) { if ( $self->bread( \$raw, 0, SIG_LEN ) == SIG_LEN ) { $rv = 1; # Unpack the signature ( $type, $sname, $lseq, $useq ) = unpack SIGNATURE, $raw; # Validate contents # # Start with file type unless ( $type eq SIG_TYPE ) { $rv = 0; pdebug( 'Invalid BAT header type (%s)', PDLEVEL1, $type ); } # stream name unless ( $sname eq $$self{streamName} ) { $rv = 0; pdebug( 'Invalid stream name (%s)', PDLEVEL1, $sname ); } # Make sure seq is legitimate $seq = longs2Quad( $lseq, $useq ); unless ( defined $seq ) { pdebug( 'this platform does not support 64b values for sequence', PDLEVEL1 ); $rv = 0; } unless ( $seq == $$self{sequence} ) { pdebug( 'Invalid sequence number for BAT (%s)', PDLEVEL1, $seq ); $rv = 0; } # Update internal values pdebug( 'BAT signature verification failure', PDLEVEL1 ) unless $rv; } else { pdebug( 'failed to read BAT header signature', PDLEVEL1 ); } pflock( $file, LOCK_UN ); } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub writeData { # Purpose: Writes all the data block numbers to the file # Returns: Boolean # Usage: $rv = $obj->writeData; my $self = shift; my $file = $$self{file}; my $rv = 0; my ( $rec, $i, $pos, $maxbats ); subPreamble(PDLEVEL3); # Hold an exclusive lock for the entire transaction if ( pflock( $file, LOCK_EX ) ) { # Calculate the maximum possible number of BATs $maxbats = int( ( $$self{blockSize} - SIG_LEN ) / DATA_LEN ); $rv = 1; $i = 0; foreach $rec ( @{ $$self{data} } ) { $pos = DATA_POS + $i * DATA_LEN; $rv = 0 unless $self->bwrite( pack( DATAIDX, quad2Longs($rec) ), $pos ) == DATA_LEN; $i++; last unless $rv; } pflock( $file, LOCK_UN ); } pdebug( 'failed to write all data block numbers to the BAT header', PDLEVEL1 ) unless $rv; subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub readData { # Purpose: Reads the data block numbers from the BAT header # Returns: Boolean # Usage: $rv = $obj->readData; my $self = shift; my $rv = 1; my ( $raw, @sraw, $bn, $lbn, $ubn, $prev ); my @data; subPreamble(PDLEVEL3); # Read the BATs section of the block if ( $self->bread( \$raw, DATA_POS ) ) { @sraw = unpack '(' . DATAIDX . ")$$self{maxData}", $raw; while (@sraw) { $lbn = shift @sraw; $ubn = shift @sraw; $bn = longs2Quad( $lbn, $ubn ); # Stop processing when it looks like we're not getting legitmate # values last unless defined $bn and $bn > $$self{blockNum}; # Error out if block numbers aren't ascending unless ( !defined $prev or $bn > $prev ) { pdebug( 'data block number appearing out of sequence', PDLEVEL1 ); $rv = 0; last; } # Save entry push @data, $bn; $prev = $bn; } # Save everything extracted $$self{data} = [@data]; pdebug( 'found %s data blocks', PDLEVEL4, scalar @data ); } else { pdebug( 'failed to read list of data blocks from BAT header', PDLEVEL1 ); $rv = 0; } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub addData { # Purpose: Adds a data block number to the BAT header # Returns: Boolean # Usage: $rv = $obj->addData($bn); my $self = shift; my $bn = shift; my $rv = 1; my $n; subPreamble( PDLEVEL3, '$', $bn ); if ( defined $bn and $bn > $$self{blockNum} ) { # Make sure we're not adding redundant entries if ( scalar grep { $_ eq $bn } @{ $$self{data} } ) { $rv = 0; pdebug( 'redundant entry for an existing data block', PDLEVEL1 ); } # Make sure new data block is a higher block number than all previous # data blocks if ( scalar grep { $_ > $bn } @{ $$self{data} } ) { $rv = 0; pdebug( 'data block number is lower than previous blocks', PDLEVEL1 ); } if ($rv) { # Write the block to the header push @{ $$self{data} }, $bn; $rv = 0 unless $self->bwrite( pack( DATAIDX, quad2Longs($bn) ), DATA_POS + DATA_LEN * $#{ $$self{data} } ) == DATA_LEN; } } else { pdebug( 'invalid data block number (%s)', PDLEVEL1, $bn ); $rv = 0; } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } 1; __END__ =head1 NAME Paranoid::IO::FileMultiplexer::Block::BATHeader - BAT Header Block =head1 VERSION $Id: lib/Paranoid/IO/FileMultiplexer/Block/BATHeader.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ =head1 SYNOPSIS $obj = Paranoid::IO::FileMultiplexer::Block::BATHeader->new($file, $blockNo, $blockSize, $strmName, $sequenceNo); $max = $obj->maxData; $seq = $obj->sequence; @data = $obj->dataBlocks; $rv = $obj->full; $rv = $obj->writeSig; $rv = $obj->readSig; $rv = $obj->writeData; $rv = $obj->readData; $rv = $obj->addData($bn); =head1 DESCRIPTION This class is not meant to be used directly, but as part of the L functionality. This provides functionality necessary for manipulation of the stream header block. This module does presume that whatever file it is being used on has already been opened in the appropriate mode, and that the L flock stack has been enabled. For the purposes of L, this is done in that class. =head1 SUBROUTINES/METHODS =head2 new $obj = Paranoid::IO::FileMultiplexer::Block::BATHeader->new($file, $blockNo, $blockSize, $strmName, $sequenceNo); This creates a new instance of a BAT header block object. It requires the filename in order to retrieve the cached file handle from L, the block number of the block, the size of the block, the name of the stream, and the block sequence number. B creating an object does not automatically create the file and/or write a signature. That must be done using the methods below. =head2 maxData $max = $obj->maxData; This method returns the maximum number of data blocks that can be tracked in a single BAT block. =head2 sequence $seq = $obj->sequence; This method returns the sequence number of the BAT. In essence, this is the ordinal index of the BAT in a stream's array of BATs. =head2 dataBlocks @data = $obj->dataBlocks; This method returns the list of data blocks being tracked by this BAT. =head2 full $rv = $obj->full; This method returns a boolean value denoting whether this BAT's array of data blocks is at maximum capacity or not. =head2 writeSig $rv = $obj->writeSig; This method writes the BAT header signature to disk, returning a boolean value denoting its success. Note that the signature contains the file format, stream name, and the BAT sequence number. This does not include the allocated data block numbers. =head2 readSig $rv = $obj->readSig; This method reads the BAT header signature from disk and performs basic validation that the information in it is acceptable. It validates that the stream name and sequence number matches what is expected and the block format is correct. If the method call was successful it will update the cached values in the object. Note that this is only the signature values, not the data block numbers. =head2 writeData $rv = $obj->writeData; This method writes the data block numbers to the header block, and returns a boolean denoting success. =head2 readData $rv = $obj->readData; This method reads the data block numbers from the file, and returns a boolean value denoting success. If the read is successful, this will update the cached data blocks in the object. =head2 addData $rv = $obj->addData($bn); This method does some basic validation of the requested BAT, and if it passes, updates the data block number list on the disk. =head1 DEPENDENCIES =over =item o L =item o L =item o L =item o L =item o L =item o L =back =head1 BUGS AND LIMITATIONS =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is free software. Similar to Perl, you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation ; either version 1 , or any later version , or b) the Artistic License 2.0 , subject to the following additional term: No trademark rights to "Paranoid" have been or are conveyed under any of the above licenses. However, "Paranoid" may be used fairly to describe this unmodified software, in good faith, but not as a trademark. (c) 2005 - 2021, Arthur Corliss (corliss@digitalmages.com) (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com) Paranoid-2.10/lib/Paranoid/IO/FileMultiplexer/Block.pm0000644000175000001440000003522414211615520022246 0ustar acorlissusers# Paranoid::IO::FileMultiplexer::Block -- Block-level Allocator/Accessor # # $Id: lib/Paranoid/IO/FileMultiplexer/Block.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ # # This software is free software. Similar to Perl, you can redistribute it # and/or modify it under the terms of either: # # a) the GNU General Public License # as published by the # Free Software Foundation ; either version 1 # , or any later version # , or # b) the Artistic License 2.0 # , # # subject to the following additional term: No trademark rights to # "Paranoid" have been or are conveyed under any of the above licenses. # However, "Paranoid" may be used fairly to describe this unmodified # software, in good faith, but not as a trademark. # # (c) 2005 - 2021, Arthur Corliss (corliss@digitalmages.com) # (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com) # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::IO::FileMultiplexer::Block; use 5.008; use strict; use warnings; use vars qw($VERSION); use base qw(Exporter); use Paranoid qw(:all); use Paranoid::IO qw(:all); use Paranoid::Debug qw(:all); use Fcntl qw(:DEFAULT :flock :mode :seek); ($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm ); use constant MINBSIZE => 4_096; use constant MAXBSIZE => 1_048_576; ##################################################################### # # Module code follows # ##################################################################### sub new { # Purpose: Creates a block object # Returns: Object reference or undef # Usage: $obj = Paranoid::IO::FileMultiplexer::Block->new( # $filename, $bnum, $bsize); my $class = shift; my $file = shift; my $bnum = shift; my $bsize = shift; my $self = { file => $file, blockNum => 0, blockSize => MINBSIZE, minPos => 0, maxPos => MINBSIZE - 1, }; subPreamble( PDLEVEL3, '$$$', $file, $bnum, $bsize ); bless $self, $class; # Check mandatory values $self = undef unless defined $bnum and defined $bsize and defined $file and length $file; pdebug( 'invalid or missing arguments', PDLEVEL1 ) unless defined $self; if ( defined $self ) { # Make sure we only have positive values for the block number and size $$self{blockNum} = int $bnum; $$self{blockSize} = int $bsize if defined $bsize; $$self{minPos} = $$self{blockNum} * $$self{blockSize}; $$self{maxPos} = $$self{minPos} + $$self{blockSize} - 1; # Make sure block size is in range and a multiple of MINBSIZE $self = undef unless $$self{blockSize} >= MINBSIZE and $$self{blockSize} <= MAXBSIZE and $$self{blockSize} % MINBSIZE == 0; pdebug( 'invalid block size', PDLEVEL1 ) unless defined $self; } subPostamble( PDLEVEL3, '$', $self ); return $self; } sub recalibrate { # Purpose: Recalibrates min/max positions in the block based # on block size. # Returns: Boolean # Usage: $rv = $obj->recalibrate; my $self = shift; $$self{minPos} = $$self{blockNum} * $$self{blockSize}; $$self{maxPos} = $$self{minPos} + $$self{blockSize} - 1; return 1; } sub blockNum { # Purpose: Returns the block number # Returns: Integer # Usage: $bn = $obj->blockNum; my $self = shift; return $$self{blockNum}; } sub blockSize { # Purpose: Returns the block size # Returns: Integer # Usage: $bs = $obj->blockSize; my $self = shift; return $$self{blockSize}; } sub minPos { # Purpose: Returns the min writable file position for the block # Returns: Integer # Usage: $minp = $obj->minPos; my $self = shift; return $$self{minPos}; } sub maxPos { # Purpose: Returns the max writable file position for the block # Returns: Integer # Usage: $maxp = $obj->maxPos; my $self = shift; return $$self{maxPos}; } sub allocate { # Purpose: Writes a new block to disk # Returns: Boolean # Usage: $rv = $obj->allocate; my $self = shift; my $file = $$self{file}; my $minPos = $$self{minPos}; my $maxPos = $$self{maxPos}; my $rv = 0; subPreamble(PDLEVEL3); if ( pflock( $$self{file}, LOCK_EX ) ) { # Seek and write a null byte at the end of the block pdebug( 'end of file should be at %s', PDLEVEL4, $minPos ); pseek( $file, 0, SEEK_END ); if ( ptell($file) == $minPos ) { pseek( $file, $maxPos, SEEK_SET ); $rv = pwrite( $file, pack 'x' ); } else { pdebug('block already allocated'); } pflock( $$self{file}, LOCK_UN ); } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub bread { # Purpose: Reads the contents of the entire block. or a specified range # Returns: Integer (bytes read) or undef on error # Usage: $bytesRead = $obj->bread(\$content); # Usage: $bytesRead = $obj->bread(\$content, $start); # Usage: $bytesRead = $obj->bread(\$content, undef, $bytes); # Usage: $bytesRead = $obj->bread(\$content, $start, $bytes); my $self = shift; my $cref = shift; my $start = shift; my $bytes = shift; my $file = $$self{file}; my $bsize = $$self{blockSize}; my $minp = $$self{minPos}; my $maxp = $$self{maxPos}; my $rv = PTRUE_ZERO; subPreamble( PDLEVEL3, '$;$$', $cref, $start, $bytes ); # NOTE: This method intentionally allows reads of a length greater than # the block size, but it will only return content from within the block # boundaries. # Error out if we were not given a valid scalar ref unless ( defined $cref and ref($cref) eq 'SCALAR' ) { $rv = undef; pdebug( 'invalid argument for content ref', PDLEVEL1 ); } # Set start to beginning of block if not specified $start = 0 unless defined $start; # Set default bytes if not specified $bytes = $bsize - $start unless defined $bytes; # Make sure start is in range if ( $minp + $start > $maxp ) { pdebug( 'starting position is out of range', PDLEVEL1 ); $rv = undef; } if ($rv) { # Make sure we limit read to our block $bytes = ( $maxp + 1 ) - ( $minp + $start ) if ( $minp + $start + $bytes ) > ( $maxp + 1 ); # Perform the read if ( pseek( $file, $minp + $start, SEEK_SET ) ) { $rv = pread( $file, $$cref, $bytes ); } else { $rv = undef; } } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub bwrite { # Purpose: Writes the contents of the entire block. or a specified range # Returns: Integer (bytes written) or undef on error # Usage: $bytesWritten = $obj->bwrite($content); # Usage: $bytesWritten = $obj->bwrite($content, $start ); # Usage: $bytesWritten = $obj->bwrite($content, $start, $length ); # Usage: $bytesWritten = $obj->bwrite($content, $start, $length, $offset ); my $self = shift; my $content = shift; my $start = shift; my $length = shift; my $offset = shift; my $file = $$self{file}; my $bsize = $$self{blockSize}; my $minp = $$self{minPos}; my $maxp = $$self{maxPos}; my $rv = PTRUE_ZERO; my $cdata = defined $content ? ( length $content ) . ' bytes' : undef; my $blkLeft; subPreamble( PDLEVEL3, '$;$$$', $cdata, $start, $length, $offset ); # NOTE: This method intentionally allows writes of a length greater than # the block size, but it will only write content from within the block # boundaries. # Error out if we were not given a valid scalar ref unless ( defined $content and length $content ) { $rv = undef; pdebug( 'invalid argument for content', PDLEVEL1 ); } # Set start to beginning of block if not specified $start = 0 unless defined $start; # Set offset to zero if not specified $offset = 0 unless defined $offset; # Set length to max content length available if not defined $length = length($content) - $offset unless defined $length; $blkLeft = $bsize - $start; $length = $blkLeft if $blkLeft < $length; # Make sure start is in range if ( $minp + $start > $maxp ) { pdebug( 'starting position is out of range', PDLEVEL1 ); $rv = undef; } if ($rv) { # Perform the write if ( pseek( $file, $minp + $start, SEEK_SET ) ) { $rv = pwrite( $file, $content, $length, $offset ); } else { $rv = undef; } } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } 1; __END__ =head1 NAME Paranoid::IO::FileMultiplexer::Block - Block-level Allocator/Accessor =head1 VERSION $Id: lib/Paranoid/IO/FileMultiplexer/Block.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ =head1 SYNOPSIS $obj = Paranoid::IO::FileMultiplexer::Block->new( $filename, $bnum, $bsize); $rv = $obj->allocate; $bn = $obj->blockNum; $bs = $obj->blockSize; $minp = $obj->minPos; $maxp = $obj->maxPos; $bytesWritten = $obj->bwrite($content); $bytesWritten = $obj->bwrite($content, $start ); $bytesWritten = $obj->bwrite($content, $start, $length ); $bytesWritten = $obj->bwrite($content, $start, $length, $offset ); $bytesRead = $obj->bread(\$content); $bytesRead = $obj->bread(\$content, $start, $bytes); $bytesRead = $obj->bread(\$content, undef, $bytes); $bytesRead = $obj->bread(\$content, $start, $bytes); $rv = $obj->recalibrate; =head1 DESCRIPTION This class is not meant to be used directly, but as part of the L functionality. It is primarily a base class from which other critical classes are derived. This module does presume that whatever file it is being used on has already been opened in the appropriate mode, and that the L flock stack has been enabled. For the purposes of L, this is done in that class. =head1 SUBROUTINES/METHODS =head2 new $obj = Paranoid::IO::FileMultiplexer::Block->new( $filename, $bnum, $bsize); This creates a new instance of a block object. It requires the filename in order to retrieve the cached file handle from L, the number of the block (using zero-based indexing), and the size of the block. It will block size and the block number to calculate its actual position within the file. =head2 blockNum $bn = $obj->blockNum; This method returns the object's assigned block number. =head2 blockSize $bs = $obj->blockSize; This method returns the object's assigned block size. =head2 minPos $minp = $obj->minPos; This method returns the minimum file position for the block. =head2 maxPos $maxp = $obj->maxPos; This method returns the maximum file position for the block. =head2 allocate $rv = $obj->allocate; This method attempts to allocate the block on the file system, and returns a boolean indicating its success. This method will fail if you attempt to allocate a block that's already been allocated, or a block whose file position is beyond the current end of the file. In other words, blocks must be allocated in sequence. =head2 recalibrate $rv = $obj->recalibrate; This method recalculates minimum/maximum file position based on the currently set block size. This should always be called after any change to blockSize. =head2 bwrite $bytesWritten = $obj->bwrite($content); $bytesWritten = $obj->bwrite($content, $start ); $bytesWritten = $obj->bwrite($content, $start, $length ); $bytesWritten = $obj->bwrite($content, $start, $length, $offset ); This method writes the passed content to the block, while making sure that the content does not overflow the block boundaries. If the I position of the write is omitted, it writes from the beginning of the block. If the I position is provided, note that this is the position relative to the block, not the file. That means you would specify values from a range of B to B<(blockSize - 1)>. This method is intentionally designed to allow you to pass more content than will fit inside of a block, and yet only write as much as will fit within the block. The calling code should use the return value to figure out what remains to be written in other blocks, as needed. =head2 bread $bytesRead = $obj->bread(\$content); $bytesRead = $obj->bread(\$content, $start); $bytesRead = $obj->bread(\$content, undef, $bytes); $bytesRead = $obj->bread(\$content, $start, $bytes); This method reads the content of the block, while making sure that the content read does not go beyond the borders of the block. If the I position of the read is omitted, it reads from the beginning of the block. Like B, this position is relative to the beginning of the block, not the file. This method is also intentionally designed to allow you to request more data than can fit within the block, yet returning only what the block contains. The calling code should use the return value to figure out what remains to be read from other blocks, as needed. =head1 DEPENDENCIES =over =item o L =item o L =item o L =item o L =back =head1 BUGS AND LIMITATIONS =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is free software. Similar to Perl, you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation ; either version 1 , or any later version , or b) the Artistic License 2.0 , subject to the following additional term: No trademark rights to "Paranoid" have been or are conveyed under any of the above licenses. However, "Paranoid" may be used fairly to describe this unmodified software, in good faith, but not as a trademark. (c) 2005 - 2021, Arthur Corliss (corliss@digitalmages.com) (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com) Paranoid-2.10/lib/Paranoid/IO/Lockfile.pm0000644000175000001440000001612114211615520017625 0ustar acorlissusers# Paranoid::IO::Lockfile -- Paranoid Lockfile support # # $Id: lib/Paranoid/IO/Lockfile.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ # # This software is free software. Similar to Perl, you can redistribute it # and/or modify it under the terms of either: # # a) the GNU General Public License # as published by the # Free Software Foundation ; either version 1 # , or any later version # , or # b) the Artistic License 2.0 # , # # subject to the following additional term: No trademark rights to # "Paranoid" have been or are conveyed under any of the above licenses. # However, "Paranoid" may be used fairly to describe this unmodified # software, in good faith, but not as a trademark. # # (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com) # (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com) # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::IO::Lockfile; use 5.008; use strict; use warnings; use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS); use base qw(Exporter); use Fcntl qw(:flock O_RDWR O_CREAT O_EXCL); use Paranoid; use Paranoid::Debug qw(:all); use Paranoid::IO; ($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm ); @EXPORT = qw(plock pexclock pshlock punlock); @EXPORT_OK = @EXPORT; %EXPORT_TAGS = ( all => [@EXPORT_OK], ); use constant PRIV_UMASK => 0660; ##################################################################### # # Module code follows # ##################################################################### sub plock { # Purpose: Opens and locks the specified file. # Returns: True/false # Usage: $rv = plock( $filename ); # Usage: $rv = plock( $filename, $lockType ); # Usage: $rv = plock( $filename, $lockType, $fileMode ); my $filename = shift; my $type = shift; my $perms = shift; my ( $rv, $fh ); subPreamble( PDLEVEL1, '$;$$', $filename, $type, $perms ); # Set the defaults $perms = PRIV_UMASK unless defined $perms; $type = LOCK_EX unless defined $type; # Open the file and apply the lock $fh = popen( $filename, O_RDWR | O_CREAT | O_EXCL, $perms ) || popen( $filename, O_RDWR, $perms ); $rv = pflock( $filename, $type ) if defined $fh; subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub pexclock { # Purpose: Applies an exclusive lock # Returns: True/false # Usage: $rv = pexclock($filename); my $filename = shift; my $mode = shift; my $rv = 1; my $fh; subPreamble( PDLEVEL1, '$;$', $filename, $mode ); $rv = plock( $filename, LOCK_EX, $mode ); subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub pshlock { # Purpose: Applies a shared lock # Returns: True/false # Usage: $rv = pshlock($filename); my $filename = shift; my $mode = shift; my $rv = 1; my $fh; subPreamble( PDLEVEL1, '$;$', $filename, $mode ); $rv = plock( $filename, LOCK_SH, $mode ); subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub punlock { # Purpose: Removes any existing locks on the file # Returns: True/false # Usage: $rv = punlock($filename); my $filename = shift; my $mode = shift; my $rv = 1; my $fh; subPreamble( PDLEVEL1, '$;$', $filename, $mode ); $rv = plock( $filename, LOCK_UN, $mode ); subPostamble( PDLEVEL1, '$', $rv ); return $rv; } 1; __END__ =head1 NAME Paranoid::IO::Lockfile - Paranoid Lockfile support =head1 VERSION $Id: lib/Paranoid/IO/Lockfile.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ =head1 SYNOPSIS use Paranoid::IO::Lockfile; use Fcntl qw(:flock); # only needed if you use plock in lieu # of the other functions $rv = plock($lockfile); $rv = plock($lockfile, LOCK_SH | LOCK_NB); $rv = plock($lockfile, LOCK_SH | LOCK_NB, $mode); $rv = pexclock($lockfile); $rv = pshlock($lockfile); $rv = punlock($lockfile); =head1 DESCRIPTION This module provides convenience functions for using a lockfile to coordinate multi-process activities. While basically just a thin wrapper for L functions it removes the small tedium of having to perform the multiple opens required to ensure all processes are working off the same files while avoiding race conditions. =head1 IMPORT LISTS This module exports the following symbols by default: plock pexclock pshlock punlock The following specialized import lists also exist: List Members -------------------------------------------------------- all @defaults =head1 SUBROUTINES/METHODS =head2 plock $rv = plock($filename); $rv = plock($filename, LOCK_EX); $rv = plock($filename, LOCK_EX, 0666); Creates or opens the requested file while applying the lock condition. The lock type defaults to B if omitted, while the file permissions default to B<0660>. As always, L applies. There is one scenario in which one would want to use I in lieu of I, etc: if you wish to perform non-blocking lock attempts. All convenience functions are blocking. =head2 pexclock $rv = pexclock($filename); $rv = pexclock($filename, $mode); A wrapper for B. =head2 pshlock $rv = pshlock($filename); $rv = pshlock($filename, $mode); A wrapper for B. =head2 punlock $rv = punlock($filename); $rv = punlock($filename, $mode); A wrapper for B. This does not close the open file handle to the lock file. For that you need to call L I function. =head1 DEPENDENCIES =over =item o L =item o L =item o L =item o L =back =head1 BUGS AND LIMITATIONS =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is free software. Similar to Perl, you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation ; either version 1 , or any later version , or b) the Artistic License 2.0 , subject to the following additional term: No trademark rights to "Paranoid" have been or are conveyed under any of the above licenses. However, "Paranoid" may be used fairly to describe this unmodified software, in good faith, but not as a trademark. (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com) (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com) Paranoid-2.10/lib/Paranoid/IO/FileMultiplexer.pm0000644000175000001440000012554314211615520021220 0ustar acorlissusers# Paranoid::IO::FileMultiplexer -- File Multiplexer Object # # $Id: lib/Paranoid/IO/FileMultiplexer.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ # # This software is free software. Similar to Perl, you can redistribute it # and/or modify it under the terms of either: # # a) the GNU General Public License # as published by the # Free Software Foundation ; either version 1 # , or any later version # , or # b) the Artistic License 2.0 # , # # subject to the following additional term: No trademark rights to # "Paranoid" have been or are conveyed under any of the above licenses. # However, "Paranoid" may be used fairly to describe this unmodified # software, in good faith, but not as a trademark. # # (c) 2005 - 2021, Arthur Corliss (corliss@digitalmages.com) # (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com) # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::IO::FileMultiplexer; use 5.008; use strict; use warnings; use vars qw($VERSION); use base qw(Exporter); use Paranoid qw(:all); use Paranoid::IO qw(:all); use Paranoid::Debug qw(:all); use Carp; use Fcntl qw(:DEFAULT :flock :mode :seek); use Paranoid::IO::FileMultiplexer::Block::FileHeader; use Paranoid::IO::FileMultiplexer::Block::StreamHeader; use Paranoid::IO::FileMultiplexer::Block::BATHeader; ($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm ); use constant PIOFMVER => '1.0'; use constant PERMMASK => 0666; use constant DEFBSIZE => 4096; use constant ADDR_BAT => 0; use constant ADDR_BLK => 1; use constant ADDR_OFT => 2; ##################################################################### # # Module code follows # ##################################################################### sub new { # Purpose: Creates a PIOFM object for manipulation # Returns: Object reference or undef # Usage: $obj = Paranoid::IO::FileMultiplexer->new( # file => $fn, # readOnly => 0, # perms => $perms, # blockSize => $bsize, # ); my $class = shift; my %args = @_; my $self = { file => undef, readOnly => 0, perms => PERMMASK ^ umask, header => undef, streams => {}, streamPos => {}, blockSize => DEFBSIZE, corrupted => 0, %args }; pdebug( 'entering w/f: %s bs: %s p: %s ro: %s', PDLEVEL1, @args{qw(file blockSize perms readOnly)} ); pIn(); bless $self, $class; # Mandatory file name required $self = undef unless defined $args{file} and length $args{file}; if ( defined $self ) { # Enable the lock stack PIOLOCKSTACK = 1; # Attempt to open the file if ( $$self{ro} ) { $self = undef unless $self->_oldFile; } else { $self = undef unless $self->_newFile or $self->_oldFile; } } else { pdebug( 'invalid file name: %s', PDLEVEL1, $args{file} ); } subPostamble( PDLEVEL1, '$', $self ); return $self; } sub _newFile { # Purpose: Attempts to open the file as a new file # Returns: Boolean # Usage: $rv = $obj->_newFile; my $self = shift; my $file = $$self{file}; my $bsize = $$self{blockSize}; my $rv = 0; my $header; subPreamble(PDLEVEL2); if ( !$$self{readOnly} ) { # Allocate the header object (it will fail on invalid block sizes) $header = Paranoid::IO::FileMultiplexer::Block::FileHeader->new( $file, $bsize ); if ( defined $header ) { # Open the file exclusively and get an flock $rv = popen( $file, O_CREAT | O_RDWR | O_EXCL, $$self{perms} ); if ($rv) { # Lock file pflock( $file, LOCK_EX ); # Allocate the block and write the initial signature $rv = $header->allocate and $header->writeSig; $$self{header} = $header if $rv; # Release the lock pflock( $file, LOCK_UN ); } } } else { pdebug( 'cannot create a new file in readOnly mode', PDLEVEL1 ); } subPostamble( PDLEVEL2, '$', $rv ); return $rv; } sub _oldFile { # Purpose: Attempts to open the file as a new file # Returns: Boolean # Usage: $rv = $obj->_newFile; my $self = shift; my $file = $$self{file}; my $bsize = $$self{blockSize}; my $rv = 0; my $header; subPreamble(PDLEVEL2); # Allocate the header object (it will fail on invalid block sizes) $header = Paranoid::IO::FileMultiplexer::Block::FileHeader->new( $file, $bsize ); if ( defined $header ) { # Open the file exclusively and get an flock $rv = popen( $file, ( $$self{readOnly} ? O_RDONLY : O_RDWR ), $$self{perms} ); if ($rv) { # Lock file pflock( $file, LOCK_SH ); # Read an existing signature $rv = $header->readSig && $header->readStreams; if ($rv) { $$self{header} = $header; $$self{blockSize} = $header->blockSize; } # Release the lock pflock( $file, LOCK_UN ); } } subPostamble( PDLEVEL2, '$', $rv ); return $rv; } sub header { # Purpose: Returns a reference to the header object # Returns: Ref # Usage: $header = $obj->header; my $self = shift; return $$self{header}; } sub _reload { # Purpose: Reloads the file header information and purges the stream # cache # Returns: Boolean # Usage: $rv = $obj->_reload; my $self = shift; my $file = $$self{file}; my $header = $$self{header}; my $rv = 1; subPreamble(PDLEVEL4); if ( pflock( $file, LOCK_SH ) ) { if ( $header->readSig && $header->readStreams ) { $$self{streams} = {}; } else { $$self{corrupt} = 1; $rv = 0; } pflock( $file, LOCK_UN ); } subPostamble( PDLEVEL4, '$', $rv ); return $rv; } sub _getStream { # Purpose: Retrieves or creates a stream header object # Returns: Ref # Usage: $ref = $obj->_getStream($name); my $self = shift; my $sname = shift; my $header = $$self{header}; my $file = $$self{file}; my ( $rv, %streams, $stream ); subPreamble( PDLEVEL2, '$$', $sname, $header ); if ( defined $sname and length $sname ) { # Reload if header fails validation $self->_reload unless $header->validateBlocks; # Create the stream object if we don't have one cached unless ( exists $$self{streams}{$sname} ) { %streams = $header->streams; if ( exists $streams{$sname} ) { $stream = Paranoid::IO::FileMultiplexer::Block::StreamHeader->new( $$self{file}, $streams{$sname}, $header->blockSize, $sname ); if ( pflock( $file, LOCK_SH ) ) { $$self{streams}{$sname} = $stream if $stream->readSig and $stream->readBATs; pflock( $file, LOCK_UN ); } unless ( exists $$self{streams}{$sname} ) { pdebug( 'stream \'%s\' failed consistency checks', PDLEVEL1, $sname ); $$self{corrupt} = 1; } } else { pdebug( 'attempted to access a non-existent stream (%s)', PDLEVEL1, $sname ); } } # Retrieve a reference to the stream object $stream = exists $$self{streams}{$sname} ? $$self{streams}{$sname} : undef; # Reload stream signature if EOS has changed outside of this process if ( defined $stream ) { unless ( $stream->validateEOS ) { unless ( $stream->readSig and $stream->readBATs ) { $stream = undef; pdebug( 'stream \'%s\' failed consistency checks', PDLEVEL1, $sname ); $$self{corrupt} = 1; } } # Return the stream reference $rv = $stream; } } subPostamble( PDLEVEL4, '$', $rv ); return $rv; } sub _getBAT { # Purpose: Returns a BAT which has been loaded and validated # Returns: Ref # Usage: $ref = $obj->_getBAT($sname, $seq); my $self = shift; my $sname = shift; my $seq = shift; my $file = $$self{file}; my ( $rv, $stream, @bats, $bat ); subPreamble( PDLEVEL4, '$$', $sname, $seq ); $stream = $self->_getStream($sname); if ( defined $stream ) { # Get the list of BATs @bats = $stream->bats; if ( $seq <= $#bats ) { $bat = Paranoid::IO::FileMultiplexer::Block::BATHeader->new( $$self{file}, $bats[$seq], $$self{blockSize}, $sname, $seq ); if ( pflock( $file, LOCK_SH ) ) { $rv = $bat if defined $bat and $bat->readSig and $bat->readData; pflock( $file, LOCK_UN ); } pdebug( 'BAT %s for stream \'%s\' failed consistency checks', PDLEVEL1, $seq, $sname ) unless $rv; } } subPostamble( PDLEVEL4, '$', $rv ); return $rv; } sub _chkData { # Purpose: Checks that a data block appears to be present # Returns: Boolean # Usage: $rv = $obj->_chkData; my $self = shift; my $bn = shift; my $file = $$self{file}; my $bsize = $$self{blockSize}; my ( $rv, $block, $raw ); subPreamble( PDLEVEL4, '$', $bn ); $block = Paranoid::IO::FileMultiplexer::Block->new( $file, $bn, $bsize ); $rv = ( defined $block and $block->bread( \$raw, 0, 1 ) == 1 ); unless ($rv) { pdebug( 'data block list at dn %s but cannot be read', PDLEVEL1, $bn ); $rv = 0; $$self{corrupted} = 1; } subPostamble( PDLEVEL4, '$', $rv ); return $rv; } sub _chkBAT { # Purpose: Checks that a BAT appears consistent # Returns: Boolean # Usage: $rv = $obj->_chkBAT($bn, $snmae, $seq); my $self = shift; my $bn = shift; my $sname = shift; my $seq = shift; my $file = $$self{file}; my $bsize = $$self{blockSize}; my ( $rv, $block, @data ); subPreamble( PDLEVEL4, '$$$', $bn, $sname, $seq ); $block = Paranoid::IO::FileMultiplexer::Block::BATHeader->new( $file, $bn, $bsize, $sname, $seq ); $rv = ( defined $block and $block->readSig and $block->readData ); unless ($rv) { pdebug( 'BAT at bn %s fails consistency checks', PDLEVEL1, $bn ); $rv = 0; $$self{corrupted} = 1; } if ($rv) { @data = $block->dataBlocks; foreach (@data) { $rv = 0 unless $self->_chkData($_) } } subPostamble( PDLEVEL4, '$', $rv ); return $rv; } sub _chkStream { # Purpose: Checks that a stream appears consistent # Returns: Boolean # Usage: $rv = $obj->_chkStream($bn, $sname); my $self = shift; my $bn = shift; my $sname = shift; my $file = $$self{file}; my $bsize = $$self{blockSize}; my ( $rv, $i, $block, @bats ); subPreamble( PDLEVEL4, '$$', $bn, $sname ); $block = Paranoid::IO::FileMultiplexer::Block::StreamHeader->new( $file, $bn, $bsize, $sname ); $rv = ( defined $block and $block->readSig and $block->readBATs ); unless ($rv) { pdebug( 'Stream at bn %s (%s) fails consistency checks', PDLEVEL1, $bn, $sname, $sname, $sname ); $rv = 0; $$self{corrupted} = 1; } if ($rv) { @bats = $block->bats; $i = 0; foreach (@bats) { $rv = 0 unless $self->_chkBAT( $_, $sname, $i ); $i++; } } subPostamble( PDLEVEL4, '$', $rv ); return $rv; } sub chkConsistency { # Purpose: Checks the file for consistency # Returns: Boolean # Usage: $rv = $obj->chkConsistency; my $self = shift; my $file = $$self{file}; my $header = $$self{header}; my $bsize = $$self{blockSize}; my $rv = 1; my %streams; subPreamble(PDLEVEL1); # TODO: There is one major flaw in this consistency check, in that is # TODO: possible to list a header block as a data block in a BAT. # TODO: Writes to said block will obviously introduce consistency errors # TODO: and corruption in the future. Depending on the size of the file, # TODO: however, doing an exhaustive search on all data blocks and making # TODO: sure they're not in use as a header block could be memory # TODO: intensive. We might have to bite the bullet, though. # # Possible solution (which isn't perfect): look for signatures and see if # they load error free. I.e., any block that starts with PIOFM. If we've # already passed the rest of the consistency checks, anything pointing to # what looks like a header block, but doesn't pass consistency checks, we # really don't care about. We might warn if it does pass, though, and # then brute-force check each data block number against a full list of # stream/BAT block numbers. # Apply a read lock for the duration if ( pflock( $file, LOCK_SH ) ) { # Check header if ( $header->readSig && $header->readStreams ) { # Check streams %streams = $header->streams; foreach ( sort keys %streams ) { $rv = 0 unless $self->_chkStream( $streams{$_}, $_ ); } } else { pdebug( 'file header failed consistency checks', PDLEVEL1 ); $$self{corrupted} = 1; $rv = 0; } pflock( $file, LOCK_UN ); } else { pdebug( 'failed to get a read lock', PDLEVEL1 ); $rv = 0; } if ($rv) { $$self{corrupted} = 0; } else { $$self{corrupted} = 1; pdebug( 'error - setting corrupted flag to true', PDLEVEL1 ); } subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub _addBlock { # Purpose: Adds a data block to the file and updates the file header # Returns: Integer (block number of new block) # Usage: $bn = $self->_addBlock; my $self = shift; my $header = $$self{header}; my ( $rv, $bn, $data ); subPreamble(PDLEVEL2); $bn = $header->blocks; $data = Paranoid::IO::FileMultiplexer::Block->new( $$self{file}, $bn, $$self{blockSize} ); $rv = $bn if defined $data and $data->allocate and $header->incrBlocks; subPostamble( PDLEVEL2, '$', $rv ); return $rv; } sub _addBAT { # Purpose: Adds a BAT to the file and updates the file header, and calls # _addBlock # Returns: Integer (block number of new BAT) # Usage: $bn = $self->_addBAT($sname, $seq); my $self = shift; my $sname = shift; my $seq = shift; my $header = $$self{header}; my ( $rv, $bn, $bat ); subPreamble( PDLEVEL2, '$$', $sname, $seq ); $bn = $header->blocks; $bat = Paranoid::IO::FileMultiplexer::Block::BATHeader->new( $$self{file}, $bn, $$self{blockSize}, $sname, $seq ); $rv = $bn if defined $bat and $bat->allocate and $bat->writeSig and $header->incrBlocks; $bat->addData( $self->_addBlock ) if defined $rv; subPostamble( PDLEVEL2, '$', $rv ); return $rv; } sub _addStream { # Purpose: Adds a Stream to the file and updates the file header, and calls # _addBAT # Returns: Integer (block number of new stream) # Usage: $bn = $self->_addStream($sname); my $self = shift; my $sname = shift; my $header = $$self{header}; my ( $rv, $bn, $stream ); subPreamble( PDLEVEL2, '$', $sname ); $bn = $header->blocks; $stream = Paranoid::IO::FileMultiplexer::Block::StreamHeader->new( $$self{file}, $bn, $$self{blockSize}, $sname ); $rv = $bn if defined $stream and $stream->allocate and $stream->writeSig and $header->incrBlocks; $stream->addBAT( $self->_addBAT( $sname, 0 ) ) if defined $rv; subPostamble( PDLEVEL2, '$', $rv ); return $rv; } sub addStream { # Purpose: Adds the requested stream # Returns: Boolean # Usage: $rv = $obj->addStream($name); my $self = shift; my $sname = shift; my $file = $$self{file}; my $header = $$self{header}; my $bypass = $$self{readOnly} || $$self{corrupted}; my $rv = 0; subPreamble( PDLEVEL1, '$', $sname ); unless ($bypass) { # Get an exclusive lock if ( pflock( $file, LOCK_EX ) ) { # Validate file header block count $rv = 1; $rv = $self->_reload unless $header->validateBlocks; # Add the stream $rv = $header->addStream( $sname, $header->blocks ) and $self->_addStream($sname) if $rv; # Release the lock pflock( $file, LOCK_UN ); } else { pdebug( 'failed to get an exclusive lock', PDLEVEL1 ); } } pOut(); pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv ); return $rv; } sub _calcAddr { # Purpose: Calculates the (BAT, Data, offset) address of the stream # position # Returns: Array (BAT #, Data #, offset) # Usage: @addr = $self->_calcAddr($pos); my $self = shift; my $pos = shift; my $bsize = $$self{blockSize}; my ( @rv, $bat, $max ); if ( $pos < $bsize ) { @rv = ( 0, 0, $pos ); } else { $bat = Paranoid::IO::FileMultiplexer::Block::BATHeader->new( $$self{file}, 0, $bsize ); if ( defined $bat ) { $max = $bat->maxData; $rv[ADDR_BAT] = int( $pos / ( $max * $bsize ) ); $rv[ADDR_BLK] = int( ( $pos - ( $rv[ADDR_BAT] * $max * $bsize ) ) / $bsize ); $rv[ADDR_OFT] = $pos - ( $rv[ADDR_BAT] * $max * $bsize + $rv[ADDR_BLK] * $bsize ); } } return @rv; } sub strmSeek { # Purpose: Updates the stream cursor position # Returns: Integer/undef on error # Usage: $rv = $obj->_strmSeek($sname, $pos, $whence); my $self = shift; my $sname = shift; my $pos = shift; my $whence = shift; my $cur = 0; my $rv = 1; subPreamble( PDLEVEL2, '$$$', $sname, $pos, $whence ); $whence = SEEK_SET unless defined $whence; $pos = 0 unless defined $whence; if ( $whence == SEEK_SET ) { $$self{streamPos}{$sname} = $pos; } else { $cur = $$self{streamPos}{$sname} if exists $$self{streamPos}{$sname}; if ( $whence == SEEK_CUR ) { $cur += $pos; } elsif ( $whence == SEEK_END ) { $cur = $$self{streams}{$sname}->eos + $pos; } else { pdebug( 'invalid value for whence in seek (%s)', PDLEVEL1, $whence ); $rv = undef; } $$self{streamPos}{$sname} = $cur; } $$self{streamPos}{$sname} = 0 if $$self{streamPos}{$sname} < 0; $rv = $$self{streamPos}{$sname} if defined $rv; $rv = PTRUE_ZERO if $rv == 0; subPostamble( PDLEVEL2, '$', $rv ); return $rv; } sub strmTell { # Purpose: Returns the current stream cursor position # Returns: Integer # Usage: $rv = $obj->_strmTell($sname); my $self = shift; my $sname = shift; my $rv; $$self{streamPos}{$sname} = 0 unless exists $$self{streamPos}{$sname}; return $$self{streamPos}{$sname}; } sub _growStream { # Purpose: Grows the stream as needed to accomodate the upcoming write # based on the address of the write's starting position # Returns: Boolean/Integer (bn of last block added) # Usage: $rv = $obj->_growStream($sname, @addr); my $self = shift; my $sname = shift; my @addr = @_; my $file = $$self{file}; my $rv = 1; my ( $max, $stream, $bat, @bats, @blocks ); subPreamble( PDLEVEL3, '$@', $sname, @addr ); # Get the stream and list of bats $stream = $self->_getStream($sname); @bats = $stream->bats; # Start padding BATs while ( $#bats <= $addr[ADDR_BAT] ) { # Add a BAT if ( $#bats < $addr[ADDR_BAT] ) { # Only add a BAT if we're still below the BAT address $rv = $self->_addBAT( $sname, scalar @bats ); if ($rv) { $stream->addBAT($rv); @bats = $stream->bats; } else { last; } } # Add data blocks as needed $bat = $self->_getBAT( $sname, $#bats ); @blocks = $bat->dataBlocks; while ( $#bats == $addr[ADDR_BAT] ? $#blocks < $addr[ADDR_BLK] : !$bat->full ) { $rv = $self->_addBlock; if ($rv) { $bat->addData($rv); @blocks = $bat->dataBlocks; } else { last; } } last if $#bats == $addr[ADDR_BAT]; } pdebug( 'failed to grow the stream (%s)', PDLEVEL1, $sname ) unless $rv; subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub _strmWrite { # Purpose: Writes to the specified stream # Returns: Integer/undef (bytes written/error) # Usage: $bytes = $obj->_strmWrite($sname, $content); my $self = shift; my $sname = shift; my $content = shift; my $file = $$self{file}; my $bsize = $$self{blockSize}; my ( $rv, $stream, $bat, $block, $pos ); my ( @addr, @blocks, $bn, $blkLeft, $offset, $clength, $chunk, $bw ); subPreamble( PDLEVEL1, '$$', $sname, $content ); if ( pflock( $file, LOCK_EX ) ) { $stream = $self->_getStream($sname); if ( defined $stream and defined $content and length $content ) { # Get the current position $pos = $self->strmTell($sname); # Get the address @addr = $self->_calcAddr( $pos + length $content ); # Allocate blocks as needed if ( $self->_growStream( $sname, @addr ) ) { @addr = $self->_calcAddr($pos); # Get the specified BAT and data block $bat = $self->_getBAT( $sname, $addr[ADDR_BAT] ); @blocks = $bat->dataBlocks; # Get the specified block $block = Paranoid::IO::FileMultiplexer::Block->new( $file, $blocks[ $addr[ADDR_BLK] ], $bsize ); if ( defined $bat and defined $block ) { # Start writing $offset = $rv = 0; while ( $rv < length $content ) { # We need to know how much room is left in the block $blkLeft = $bsize - $addr[ADDR_OFT]; # We need to know if the remaining content will fit in # that block $clength = length($content) - $offset; $chunk = $clength <= $blkLeft ? $clength : $blkLeft; # Write the chunk $bw = $block->bwrite( $content, $addr[ADDR_OFT], $chunk, $offset ); $rv += $bw; $offset += $bw; $pos += $bw; # Exit if we couldn't write the full chunk unless ( $bw == $chunk ) { pdebug( 'failed to write entire contents: %s bytes', PDLEVEL1, $rv ); last; } # Get the next block if we have bytes left if ( $rv < length $content ) { @addr = $self->_calcAddr($pos); unless ( $bat->sequence == $addr[ADDR_BAT] ) { $bat = $self->_getBAT( $sname, $addr[ADDR_BAT] ); @blocks = $bat->dataBlocks; } # Get the specified block $block = Paranoid::IO::FileMultiplexer::Block->new( $file, $blocks[ $addr[ADDR_BLK] ], $bsize ); } } } # Update stream position and EOS if ($rv) { $self->strmSeek( $sname, $pos, SEEK_SET ); $stream->writeEOS($pos) if $stream->eos < $pos; } } } pflock( $file, LOCK_UN ); } subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub strmWrite { # Purpose: Calls _strmWrite after making sure the file can be written to # Returns: Integer/undef # Usage: $bw = $obj->strmWrite($sname, $content); my $self = shift; my @args = @_; my $bypass = $$self{readOnly} || $$self{corrupted}; pdebug( 'can\'t write to files that are corrupted or read-only', PDLEVEL1 ) if $bypass; return $bypass ? undef : $self->_strmWrite(@args); } sub _strmRead { # Purpose: Reads from the specified stream # Returns: Integer/undef (bytes read/error) # Usage: $bytes = $obj->_strmRead($sname, $content, $bytes); my $self = shift; my $sname = shift; my $cref = shift; my $btr = shift || 0; my $file = $$self{file}; my $bsize = $$self{blockSize}; my $rv = 0; my ( $stream, $pos, $eos, @addr, $content ); my ( $bat, @blocks, $block, $ctr, $br, $offset ); subPreamble( PDLEVEL1, '$$$', $sname, $cref, $btr ); if ( pflock( $file, LOCK_SH ) ) { $stream = $self->_getStream($sname); if ( defined $stream and defined $cref and ref $cref eq 'SCALAR' ) { # Get the current position $pos = $self->strmTell($sname); # Get the address @addr = $self->_calcAddr($pos); # Get the End Of Stream position $eos = $stream->eos; # Start reading $$cref = ''; while ( $pos < $eos and $rv < $btr ) { # Get the specified BAT $bat = $self->_getBAT( $sname, $addr[ADDR_BAT] ); if ( defined $bat ) { # Get the specified data block @blocks = $bat->dataBlocks; $block = Paranoid::IO::FileMultiplexer::Block->new( $file, $blocks[ $addr[ADDR_BLK] ], $bsize ); if ( defined $block ) { # Take and early out if pos equals eos last unless $pos < $eos; # Figure out how much of the block we have left to # read $ctr = $bsize - $addr[ADDR_OFT]; # Reduce it if the read finishes in this block $ctr = $btr - $rv if $ctr > $btr - $rv; # Reduce it further if EOS is even closer $ctr = $eos - $pos if $ctr > $eos - $pos; # Read the chunk $br = $block->bread( \$content, $addr[ADDR_OFT], $ctr ); $rv += $br; $pos += $br; @addr = $self->_calcAddr($pos); $$cref .= $content; unless ( $br == $ctr ) { pdebug( 'failed to read entire chunk: %s/%s bytes', PDLEVEL1, $br, $ctr ); last; } } } } # Update stream pointer $self->strmSeek( $sname, $pos, SEEK_SET ); } else { if ( defined $stream ) { pdebug( 'invalid value passed for the content reference: %s', PDLEVEL1, $cref ); $rv = undef; } } pflock( $file, LOCK_UN ); } subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub strmRead { # Purpose: Calls _strmRead after making sure the file can be read from # Returns: Integer/undef # Usage: $br = $obj->strmRead($stream, \$content, $bytes); my $self = shift; my @args = @_; my $bypass = $$self{corrupted}; pdebug( 'can\'t read from files that are corrupted', PDLEVEL1 ) if $bypass; return $bypass ? undef : $self->_strmRead(@args); } sub strmAppend { # Purpose: Seeks to the end of the stream and writes new content there # Returns: Integer/undef (bytes written/error) # Usage: $bytes = $obj->_strmAppend($sname, $content); my $self = shift; my $sname = shift; my $content = shift; my $file = $$self{file}; my ( $rv, $stream, $pos ); subPreamble( PDLEVEL1, '$$', $sname, $content ); if ( pflock( $file, LOCK_EX ) ) { $stream = $self->_getStream($sname); if ( defined $stream ) { $pos = $self->strmTell($sname); if ( $self->strmSeek( $sname, 0, SEEK_END ) ) { $rv = $self->strmWrite( $sname, $content ); $self->strmSeek( $sname, $pos, SEEK_SET ); } } } subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub _strmTruncate { # Purpose: Truncates the stream to the specified length. This will zero # out any data written past the new EOS. # Returns: Boolean # Usage: $rv = $obj->_strmTruncate($sname, $neos); my $self = shift; my $sname = shift; my $neos = shift; my $file = $$self{file}; my ( $rv, $stream, $eos, $zeroes, $zl ); subPreamble( PDLEVEL1, '$$', $sname, $neos ); if ( pflock( $file, LOCK_EX ) ) { $stream = $self->_getStream($sname); if ( defined $stream ) { $eos = $stream->eos; if ( $neos < $eos ) { # Zero out old data beyond the new EOS $zl = $eos - $neos; $zeroes = pack "x$zl"; $rv = $self->strmSeek( $sname, $neos, SEEK_SET ) and $self->strmWrite( $sname, $zeroes ) and $stream->writeEOS($neos); } } } subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub strmTruncate { # Purpose: Calls _strmTruncate after making sure the file can be written to # Returns: Integer/undef # Usage: $bw = $obj->strmTruncate($sname, $neos); my $self = shift; my @args = @_; my $bypass = $$self{readOnly} || $$self{corrupted}; pdebug( 'can\'t write to files that are corrupted or read-only', PDLEVEL1 ) if $bypass; return $bypass ? undef : $self->_strmTruncate(@args); } sub DESTROY { my $self = shift; pclose( $$self{file} ) if defined $$self{file} and length $$self{file}; return 1; } 1; __END__ =head1 NAME Paranoid::IO::FileMultiplexer - File Multiplexer =head1 VERSION $Id: lib/Paranoid/IO/FileMultiplexer.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ =head1 SYNOPSIS $obj = Paranoid::IO::FileMultiplexer->new( file => $fn, readOnly => 0, perms => $perms, blockSize => $bsize, ); $header = $obj->header; $rv = $obj->chkConsistency; $rv = $obj->addStream($name); $rv = $obj->strmSeek($sname, $pos, $whence); $rv = $obj->strmTell($sname); $bw = $obj->strmWrite($sname, $content); $br = $obj->strmRead($stream, \$content, $bytes); $bw = $obj->strmAppend($sname, $content); $bw = $obj->strmTruncate($sname, $neos); =head1 DESCRIPTION This class produces file multiplexer objects that multiplex I/O streams into a single file. This allows I/O patterns that would normally be applied to multiple files to be applied to one, with full support for concurrent access by multiple processes on the same system. At its most basic, one could use these objects as an archive format for multiple files. At its most complex, this could be a database backend file, similar to sqlite or Berkeley DB. This does require flock support for the file. =head2 CAVEATS FOR USAGE This class is built essentially as a block allocation tool, which does have some side effects that must be anticipated. Full support is available for both 32-bit and 64-bit file systems, and files produced can be exchange across both types of platforms with no special handling, at least until the point the file grows beyond the capabilities of a 32 bit platform. Similarly, portability should work fine across both endian platforms. That said, the simplicity of this design did require some compromises, the first being the number of supported "streams" that can be stored inside a single file. That is a function of the block size chosen for the file. All allocated streams are tracked in the file header block, so the number of streams is constrained by the number that can be recorded in that block. Likewise, the maximum size of a stream is also limited by the block size, since the stream head block can only track so many block allocation tables, and each block allocation table can only track so many data blocks. Practically speaking, for many use cases this should not be an issue, but you can get an idea of the impact on both 32-bit and 64-bit systems like so: 32b/4KB 64b/4KB -------------------------------------------------------------------------- Max File Size: 4294967295 (4.00GB) 18446744073709551615 (16.00EX) Max Streams: 135 135 Max Stream Size: 1052872704 (1004.10MB) 1052872704 (1004.10MB) 32b/8KB 64b/8KB -------------------------------------------------------------------------- Max File Size: 4294967295 (4.00GB) 18446744073709551615 (16.00EX) Max Streams: 272 272 Max Stream Size: 4294967295 (4.00GB) 8506253312 (7.92GB) As you can see, 8KB blocks will provide full utilization of your file system capabilities on a 32-bit platform, but on a 64-bit platform, you are still artificially capped on how much data can be stored in an individual stream. The number of streams will always limited identically on both platforms based on the block size. B The actual limits of file sizes aren't dependent upon the native size of longs or quads, but the file system design, itself. Some file systems designed for 32-bit processors reserved the highest bit, which made the highest addressable space in a file 2GB instead of 4GB. Other filesystems had limits that were a function of inode size and other aspects of the formatted file system. End sum, the true limit for file size may be outside of the ability for this module to detect and accomodate gracefully. One final caveat should be noted regarding I/O performance. The supported block sizes are intentionally limited in hopes of avoiding double-write penalties due to block alignment issues on the underlying file system. At the same time, the block size also serves as a kind of crude tuning capability for the size of I/O operations. No individual I/O, whether read or write, will exceed the size of a block. You, as the developer, can call the class API with reads of any size you wish, of course, but behind the scenes it will be broken up into block-sized reads at most. For those reasons, when choosing your block size one should choose based on the best compromise between I/O performance and the minimum number of streams (or maximum stream size) anticipated. As a final note, one should also remember that space is allocated to the file in block sized chunks. That means creating a new file w/1MB block size, containing one stream, but with nothing written to the stream, will create a file 4MB in size. That's due to the preallocation of the file header, a stream header, the stream's first block allocation table, and an initial data block. =head1 SUBROUTINES/METHODS =head2 new $obj = Paranoid::IO::FileMultiplexer->new( file => $fn, readOnly => 0, perms => $perms, blockSize => $bsize, ); This class method creates new objects for accessing the contents of the pass file. It will create a new file if missing, or open an existing file and retrieve the metadata for tuning. Only the file name is mandatory. Block size defaults to 4KB, but if specified, can support from 4KB to 1MB block sizes, as long as the block size is a multiple of 4KB. =head2 header $header = $obj->header; This method returns a reference to the file header block object. Typically, this has no practical value to the developer, but the file header does provide a L method that returns a hash with some predicted sizing limitations. if you want to know the maximum number of supported streams or the maximum size of an individual stream, this could be useful. Calling any other method for that class, however, could cause corruption of your file. =head2 chkConsistency $rv = $obj->chkConsistency; This method performs a high-level consistency check of the file structure. At this time it is limited to ensuring that every header block (file, stream, and BAT) has a viable signature, and all records inside those blocks are allocated and match signatures where appropriate. If this method detects any inconsistencies it will mark the object as corrupted, which will prevent any further writes to the file in hopes that further corruption can be avoided. The file format of this multiplexer is such that a good deal of data can be recovered even with the complete loss of the file header. Corruption in a stream header can even be recovered from. Only the loss of a BAT header can prevent data from being recovered, but even then that will only impact the stream it belongs to. It should not impact other streams. Take this with a grain of salt, of course. There are always caveats to that rule, depending on whether the corruption has been detected prior to dangerous writes. Every read and write to a stream triggers a few basic consistency checks prior to progressing, but they are not as thorough as this method's process, lest it have and adverse impact on performance. This returns a boolean value. =head2 addStream $rv = $obj->addStream($name); This method adds a stream to the file, triggering the automatic allocation of three blocks (a stream header, the first stream BAT, and the first data block). It returns a boolean value, denoting success or failure. =head2 strmSeek $rv = $obj->strmSeek($sname, $pos, $whence); This method acts the same as the core L, taking the same arguments, but with the substitution of the stream name for the file handle. It's return value is also the same. Note that the position returned is relative to the data stream, not the file itself. =head2 strmTell $rv = $obj->strmTell($sname); This method acts the same as the core L, taking the same arguments, but with the substitution of the stream name for the file handle. Like L, the position returned is relative to the data stream, not the file itself. =head2 strmWrite $bw = $obj->strmWrite($sname, $content); This method acts similarly to a very simplifed L. It does not support length and offset arguments, only the content itself. It will presume that the stream position has been adjusted as needed prior to invocation. This returns the number of bytes written. If everything is working appropriately, that should match the byte length of the content itself. =head2 strmRead $br = $obj->strmRead($stream, \$content, $bytes); This method acts similarly to a very simplified L. It does not support offset arguments, only a scalar reference and the number of bytes to read. It also presumes that the stream position has been adjusted as needed prior to invocation. This returns the number of bytes read. Unless you've asked for more data than has been written to the stream, this should match the number of bytes requested. =head2 strmAppend $bw = $obj->strmAppend($sname, $content); This method acts similarly to L's L. It always seeks to the end of the written data stream before appending the requested content. Like L, it will return the number of bytes written. Like L, it does not move the stream position, should you perform additional writes or reads. =head2 strmTruncate $bw = $obj->strmTruncate($sname, $neos); This method acts similarly to L. It returns a boolean value denoting failure or success. =head2 DESTROY Obviously, one would never need to call this directly, but it is documented here to inform the developer that once an object goes out of scope, it will call L on the file, explicitly closing and purging any cached file handles from L's internal cache. =head1 DEPENDENCIES =over =item o L =item o L =item o L =item o L =item o L =item o L =item o L =item o L =back =head1 BUGS AND LIMITATIONS =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is free software. Similar to Perl, you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation ; either version 1 , or any later version , or b) the Artistic License 2.0 , subject to the following additional term: No trademark rights to "Paranoid" have been or are conveyed under any of the above licenses. However, "Paranoid" may be used fairly to describe this unmodified software, in good faith, but not as a trademark. (c) 2005 - 2021, Arthur Corliss (corliss@digitalmages.com) (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com) Paranoid-2.10/lib/Paranoid/IO/Line.pm0000644000175000001440000005444214211615520016774 0ustar acorlissusers# Paranoid::IO::Line -- Paranoid Line-based I/O functions # # $Id: lib/Paranoid/IO/Line.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ # # This software is free software. Similar to Perl, you can redistribute it # and/or modify it under the terms of either: # # a) the GNU General Public License # as published by the # Free Software Foundation ; either version 1 # , or any later version # , or # b) the Artistic License 2.0 # , # # subject to the following additional term: No trademark rights to # "Paranoid" have been or are conveyed under any of the above licenses. # However, "Paranoid" may be used fairly to describe this unmodified # software, in good faith, but not as a trademark. # # (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com) # (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com) # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::IO::Line; use 5.008; use strict; use warnings; use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS); use base qw(Exporter); use Fcntl qw(:DEFAULT :seek :flock :mode); use Paranoid qw(:all); use Paranoid::Debug qw(:all); use Paranoid::IO qw(:all); use Paranoid::Input qw(:all); ($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm ); @EXPORT = qw(sip nlsip tailf nltailf slurp nlslurp piolClose); @EXPORT_OK = ( @EXPORT, qw(PIOMAXLNSIZE) ); %EXPORT_TAGS = ( all => [@EXPORT_OK], ); use constant STAT_INO => 1; use constant STAT_SIZ => 7; use constant PDEFLNSZ => 2048; use constant PBFLAG => 0; use constant PBBUFF => 1; use constant PBF_DRAIN => 0; use constant PBF_NORMAL => 1; use constant PBF_DELETE => -1; ##################################################################### # # Module code follows # ##################################################################### { my $mlnsz = PDEFLNSZ; sub PIOMAXLNSIZE : lvalue { # Purpose: Gets/sets default line size of I/O # Returns: $mlnsz # Usage: $limit = PIOMAXLNSIZE; # Usage: FSZLIMIT = 100; $mlnsz; } # Manage buffers: $buffers{$name} => [$flag, $content ]; my %buffers; sub _chkBuffer { return exists $buffers{ $_[0] } } sub _chkStat { # Purpose: Checks stat data to see if the underlying # file has changed # Returns: Boolean # Usage: $rv = _chkStat($file); my $file = shift; my $rv = 0; my ( $fh, $fpos, @fstat, @fhstat ); subPreamble( PDLEVEL3, '$', $file ); # Check to see if we can get a valid file handle if ( defined( $fh = popen( $file, O_RDONLY ) ) ) { @fhstat = stat $fh; $fpos = ptell($fh); if ( @fhstat and $fpos < $fhstat[STAT_SIZ] ) { # Still have content to read, continue on pdebug( 'still have content to drain', PDLEVEL3 ); $rv = 1; } else { # Check the file system to see if we're still # operating on the same file @fstat = stat $file; if ( scalar @fstat ) { # Check inode if ( $fhstat[STAT_INO] != $fstat[STAT_INO] ) { pdebug( 'file was replaced with a new file', PDLEVEL3 ); } else { if ( $fstat[STAT_SIZ] < $fpos ) { pdebug( 'file was truncated', PDLEVEL3 ); } else { pdebug( 'file is unchanged', PDLEVEL3 ); $rv = 1; } } } else { pdebug( 'file was deleted', PDLEVEL3 ); } } } else { pdebug( 'invalid/non-existent file', PDLEVEL3 ); } subPostamble( PDLEVEL3, '$', $rv ); return $rv; } sub piolClose { # Purpose: Closes file handles and deletes the associated # buffer # Returns: Boolean # Usage: $rv = piolClose($file); my $file = shift; delete $buffers{$file}; return pclose($file); } sub sip ($\@;$$) { # Purpose: Reads a chunk from the passwed handle or file name # Returns: Number of lines read or undef critical failures # Usage: $nlines = sip($fh, @lines); # Usage: $nlines = sip($filename, @lines); # Usage: $nlines = sip($filename, @lines, 1); my $file = shift; my $aref = shift; my $doChomp = shift; my $noLocks = shift; my $rv = 1; my ( $buffer, $bflag, $in, $content, $bread, $irv, @tmp, $line ); subPreamble( PDLEVEL1, '$\@;$$', $file, $aref, $doChomp, $noLocks ); @$aref = (); # Check the file piolClose($file) unless _chkStat($file); # Get/initialize buffer if ( exists $buffers{$file} ) { $bflag = $buffers{$file}[PBFLAG]; $buffer = $buffers{$file}[PBBUFF]; } else { $buffers{$file} = [ PBF_NORMAL, '' ]; $buffer = ''; $bflag = PBF_NORMAL; } # Read what we can $content = ''; $bread = 0; while ( $bread < PIOMAXFSIZE ) { $irv = $noLocks ? pnlread( $file, $in ) : pread( $file, $in ); if ( defined $irv ) { $bread += $irv; $content .= $in; last if $irv < PIOBLKSIZE; } else { $rv = undef; last; } } # Post processing if ($rv) { if ( length $content ) { # Add the buffer $content = "$buffer$content"; # Process buffer drain conditions pdebug( 'starting buffer flag: (%s)', PDLEVEL4, $bflag ); pdebug( 'starting buffer: (%s)', PDLEVEL4, $buffer ); if ( !$bflag and $content =~ /@{[NEWLINE_REGEX]}/so ) { pdebug( 'draining to next newline', PDLEVEL4 ); $content =~ s/^.*?@{[NEWLINE_REGEX]}//so; $bflag = PBF_NORMAL; $buffer = ''; } # Check for newlines if ( $content =~ /@{[NEWLINE_REGEX]}/so ) { # Split lines along newline boundaries @tmp = split m/(@{[NEWLINE_REGEX]})/so, $content; while ( scalar @tmp > 1 ) { if ( length $tmp[0] > PIOMAXLNSIZE ) { splice @tmp, 0, 2; $line = undef; } else { $line = join '', splice @tmp, 0, 2; } push @$aref, $line; } # Check for undefined lines $rv = scalar @$aref; @$aref = grep {defined} @$aref; if ( $rv != scalar @$aref ) { Paranoid::ERROR = pdebug( 'found %s lines over PIOMAXLNSIZE', PDLEVEL1, $rv - @$aref ); $rv = undef; } # Check for an unterminated line at the end and # buffer appropriately if ( scalar @tmp ) { # Content left over, update the buffer if ( length $tmp[0] > PIOMAXLNSIZE ) { $buffer = ''; $bflag = PBF_DRAIN; $rv = undef; Paranoid::ERROR = pdebug( 'buffer is over PIOMAXLNSIZE', PDLEVEL1 ); } else { $buffer = $tmp[0]; $bflag = PBF_NORMAL; } } else { # Nothing left over, make sure the buffer is empty $buffer = ''; $bflag = PBF_NORMAL; } } else { # Check buffered block for PIOILNSIZE limit if ( length $content > PIOMAXLNSIZE ) { $buffer = ''; $bflag = PBF_DRAIN; $rv = undef; Paranoid::ERROR = pdebug( 'block is over PIOMAXLNSIZE', PDLEVEL1 ); } else { $rv = 0; $buffer = $content; $bflag = PBF_NORMAL; } } pdebug( 'ending buffer flag: (%s)', PDLEVEL4, $bflag ); pdebug( 'ending buffer: (%s)', PDLEVEL4, $buffer ); } else { $rv = 0; } } # Set PTRUE_ZERO if needed $rv = PTRUE_ZERO if defined $rv and $rv == 0; # Save the buffer $buffers{$file}[PBFLAG] = $bflag; $buffers{$file}[PBBUFF] = $buffer; # Chomp if necessary pchomp(@$aref) if $doChomp and scalar @$aref; pdebug( 'returning %s lines', PDLEVEL2, scalar @$aref ); subPostamble( PDLEVEL1, '$', $rv ); return $rv; } } sub nlsip { # Purpose: Wrapper for sip that enables non-locking reads # Returns: Return value from sip # Usage: $nlines = nlsip($file, @lines); my $file = shift; my $aref = shift; my $doChomp = shift; return sip( $file, @$aref, $doChomp, 1 ); } sub tailf ($\@;$$$) { # Purpose: Augments sip's tailing abilities by seeking to # the end (or, optionally, backwards) # Returns: Number of lines tailed # Usage: $nlines = tail($filename, @lines); # Usage: $nlines = tail($filename, @lines, $chomp); # Usage: $nlines = tail($filename, @lines, $lnOffset); my $file = shift; my $aref = shift; my $doChomp = shift || 0; my $offset = shift || -10; my $noLocks = shift; my ( $rv, $ofsb, @lines ); subPreamble( PDLEVEL1, '$\@;$$$', $file, $aref, $doChomp, $offset, $noLocks ); @$aref = (); # Check to see if we've already opened this file if ( _chkBuffer($file) ) { # Offset is only used on the initial open $offset = 0; } else { # TODO: At some point we might want to honor positive offsets to mimic # the behavior of UNIX tail # Calculate how far back we need to go from the end $ofsb = $offset * ( PIOMAXLNSIZE +1 ); Paranoid::ERROR = pdebug( 'WARNING: called with a positive line offset', PDLEVEL1 ) unless $ofsb < 0; # Open the file and move the cursor pseek( $file, $ofsb, SEEK_END ) if popen( $file, O_RDONLY ); } # If $offset is set we have trailing lines to handle if ($offset) { # Consume everything to the end of the file do { $noLocks ? nlsip( $file, @lines, $doChomp ) : sip( $file, @lines, $doChomp ); push @$aref, @lines; } while scalar @lines; # Trim list to the request size if ( scalar @$aref > abs $offset ) { splice @$aref, 0, @$aref - abs $offset; } $rv = scalar @$aref; $rv = PTRUE_ZERO unless $rv; } else { # Do a single sip $rv = $noLocks ? nlsip( $file, @$aref, $doChomp ) : sip( $file, @$aref, $doChomp ); } subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub nltailf ($\@;$$$) { # Purpose: Wrapper for sip that enables non-locking reads # Returns: Return value from sip # Usage: $nlines = nlsip($file, @lines); my $file = shift; my $aref = shift; my $doChomp = shift; my $offset = shift; return tailf( $file, @$aref, $doChomp, $offset, 1 ); } sub slurp ($\@;$$) { # Purpose: Reads a file into memory # Returns: Number of lines read/undef # Usage: $nlines = slurp($filename, @lines; # Usage: $nlines = slurp($filename, @lines, 1); my $file = shift; my $aref = shift; my $doChomp = shift || 0; my $noLocks = shift; my $rv = 1; my @fstat; subPreamble( PDLEVEL1, '$\@;$$', $file, $aref, $doChomp, $noLocks ); # Start sipping $rv = sip( $file, @$aref, $doChomp, $noLocks ); if ( ref $file eq 'GLOB' ) { @fstat = stat $file if fileno $file; } else { @fstat = stat $file; } if ( scalar @fstat and $fstat[STAT_SIZ] > PIOMAXFSIZE ) { Paranoid::ERROR = pdebug( 'file size exceeds PIOMAXFSIZE', PDLEVEL1 ); $rv = undef; } # Count lins if sip never complained $rv = scalar @$aref if defined $rv; # Close everything out piolClose($file); subPostamble( PDLEVEL1, '$', $rv ); return $rv; } sub nlslurp ($\@;$$) { # Purpose: Performs a non-locking slurp # Returns: Number of lines/undef # Usage: $nlines = nlslurp($filename, @lines); # Usage: $nlines = nlslurp($filename, @lines, 1); my $file = shift; my $aref = shift; my $doChomp = shift || 0; return slurp( $file, @$aref, $doChomp, 1 ); } 1; __END__ =head1 NAME Paranoid::IO::Line - Paranoid Line-based I/O functions =head1 VERSION $Id: lib/Paranoid/IO/Line.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ =head1 SYNOPSIS use Paranoid::IO::Line; PIOMAXLNSIZE = 4096; $nlines = sip($filename, @lines); $nlines = sip($filename, @lines, 1); $nlines = tailf($filename, @lines); $nlines = tailf($filename, @lines, 1); $nlines = tailf($filename, @lines, 1, -100); piolClose($filename); $nlines = slurp($filename, @lines); # Non-locking variants $nlines = nlsip($filename, @lines); $nlines = nltailf($filename, @lines); $nlines = nlslurp($filename, @lines); =head1 DESCRIPTION This module extends and leverages L's capabilities with an eye towards line-based text files, such as log files. It does so while maintaining a paranoid stance towards I/O. For that reason the functions here only work on limited chunks of data at a time, both in terms of maximum memory kept in memory at a time and the maximum record length. L provides I which controls the former, but this module provides I which controls the latter. Even with the paranoid slant of these functions they should really be treated as convenience functions which can simplify higher level code without incurring any significant risk to the developer or system. They inherit not only opportunistic I/O but platform-agnostic record separators via internal use of I from L. B while this does build off the foundation provided by L it is important to note that you should not work on the same files using :'s functions while also using the functions in this module. While the former works from raw I/O the latter has to manage buffers in order to identify record boundaries. If you were to, say, I from a file, then I or I elsewhere it would render those buffers not only useless, but corrupt. This is important to note since the functions here do leverage the file handle caching features provided by I. It should also be noted that since we're anticipating line-based records we expect every line, even the last line in a file, to be properly terminated with a record separator (new line sequence). As with all L modules string descriptions of errors can be retrieved from L as they occur. =head1 IMPORT LISTS This module exports the following symbols by default: sip nlsip tailf nltailf slurp nlslurp piolClose The following specialized import lists also exist: List Members -------------------------------------------------------- all @defaults PIOMAXLNSIZE =head1 SUBROUTINES/METHODS =head2 PIOMAXLNSIZE The valute returned/set by this lvalue function is the maximum line length supported by functions like B (documented below). Unless explicitly set this defaults to 2KB. Any lines found which exceed this are discarded. =head2 sip $nlines = sip($filename, @lines); $nlines = sip($filename, @lines, 1); This function allows you to read a text file into memory in chunks, the lines of which are placed into the passed array reference. The chunks are read in at up to L in size at a time. File locking is used and autochomping is also supported. This returns the number of lines extracted or boolean false if any errors occurred, such as lines exceeding I or other I/O errors. If there were no errors but also no content it will return B<0 but true>, which will satisfy boolean tests. The passed array is always purged prior to execution. This can potentially help differentiate types of errors: $nlines = sip($filename, @lines); warn "successfully extracted lines" if $nlines and scalar @lines; warn "no errors, but no lines" if $nlines and ! scalar @lines; warn "line length exceeded on some lines" if !$nlines and scalar @lines; warn "I/O errors or all lines exceeded line length" if !$nlines and ! scalar @lines; Typically, if all one cares about is extracting good lines and discarding bad ones all you need is: warn "good to go" if scalar @lines or $nlines; # or, more likely: if (@lines) { # process input... } B I does try to check the file stat with every call. This allows us to automatically flush buffers and reopen files in the event that the file you're sipping from was truncated, deleted, or overwritten. The third argument is a boolean option which controls whether lines are automatically chomped or not. It defaults to not. =head2 nlsip $nlines = nlsip($filename, @lines); $nlines = nlsip($filename, @lines, 1); A very thin wrapper for I that disables file locking. =head2 tailf $nlines = tailf($filename, @lines); $nlines = tailf($filename, @lines, 1); $nlines = tailf($filename, @lines, 1, -100); The only difference between this function and B is that tailf opens the file and immediately seeks to the end. If an optional fourth argument is passed it will seek backwards to extract and return that number of lines (if possible). Depending on the number passed one must be prepared for enough memory to be allocated to store B * that number. If no number is specified it is assumed to be B<-10>. Specifying this argument on a file already opened by I or I will have no effect. Return values are identical to I. =head2 nltailf $nlines = nltailf($filename, @lines); $nlines = nltailf($filename, @lines, -100); $nlines = nltailf($filename, @lines, -100, 1); A very thin wrapper for I that disables file locking. =head2 slurp $nlines = slurp($filename, @lines); $nlines = slurp($filename, @lines, 1); This function is essentially another wrapper for I, but with some different behavior. While I was written from the expectation that the developer would be either working on chunks from a very large file or a file that may grow while being accessed. I, on the other hand, expects to work exclusively on small files that can safely fit into memory. It also sees no need to cache file handles since all operations will subsequently be done in memory. Files with slurp are explicitly closed after the read. All the normal safeguards apply: I is the largest amount of data that will be read into memory, and all lines must be within I. The third argument is a boolean option which controls whether lines are automatically chomped or not. It defaults to not. =head2 nlslurp $nlines = nlslurp($filename, @lines); $nlines = nlslurp($filename, @lines, 1); A very thin wrapper for I that disables file locking. =head2 piolClose $rv = piolClose($filename); This closes all file handles and deletes any existing buffers. Works indiscriminatley and returns the exit value of I. =head1 DEPENDENCIES =over =item o L =item o L =item o L =item o L =item o L =back =head1 BUGS AND LIMITATIONS While all of these functions will just as happily accept file handles as well as file names doing will almost certainly cause any number of bugs. Beyond the inherited L issues (like not getting the fork-safe features for any file handle opened directly by the developer) there are other issues. Buffers, for instance, can only be managed by one consistent name, there is no way to correlate them and make them interchangeable. There are other subtleties as well, but there is no need to detail them all. Suffice it to say that when using this module one should only use file names, and use them consistently. =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is free software. Similar to Perl, you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation ; either version 1 , or any later version , or b) the Artistic License 2.0 , subject to the following additional term: No trademark rights to "Paranoid" have been or are conveyed under any of the above licenses. However, "Paranoid" may be used fairly to describe this unmodified software, in good faith, but not as a trademark. (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com) (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com) Paranoid-2.10/lib/Paranoid/Args.pm0000644000175000001440000012736614211615520016500 0ustar acorlissusers# Paranoid::Args -- Command-line argument parsing functions # # $Id: lib/Paranoid/Args.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ # # This software is free software. Similar to Perl, you can redistribute it # and/or modify it under the terms of either: # # a) the GNU General Public License # as published by the # Free Software Foundation ; either version 1 # , or any later version # , or # b) the Artistic License 2.0 # , # # subject to the following additional term: No trademark rights to # "Paranoid" have been or are conveyed under any of the above licenses. # However, "Paranoid" may be used fairly to describe this unmodified # software, in good faith, but not as a trademark. # # (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com) # (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com) # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::Args; use 5.008; use strict; use warnings; use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS); use base qw(Exporter); use Paranoid; use Paranoid::Debug qw(:all); ($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm ); @EXPORT = qw(parseArgs); @EXPORT_OK = ( @EXPORT, qw(PA_DEBUG PA_VERBOSE PA_HELP PA_VERSION) ); %EXPORT_TAGS = ( all => [@EXPORT_OK], template => [qw(PA_DEBUG PA_VERBOSE PA_HELP PA_VERSION)], ); # I know, this really doesn't protect the contents... use constant PA_DEBUG => { Short => 'D', Long => 'debug', CountShort => 1, }; use constant PA_VERBOSE => { Short => 'v', Long => 'verbose', CountShort => 1, }; use constant PA_HELP => { Short => 'h', Long => 'help', }; use constant PA_VERSION => { Short => 'V', Long => 'version', }; ##################################################################### # # Module code follows # ##################################################################### { # Internal boolean flag for noOptions my $noOptions = 0; sub _NOOPTIONS : lvalue { # Purpose: Gets/sets value of boolean flag $noOptions # Returns: Value of $noOptions # Usage: $flag = _NOOPTIONS; # Usage: _NOOPTIONS = 1; $noOptions; } # Internal errors array my @errors; sub _resetErrors { # Purpose: Empties @errors # Returns: True (1) # Usage: resetErrors(); @errors = (); return 1; } sub _pushErrors { # Purpose: Pushes a new string onto the @errors array # Returns: Same argument as called with # Usage: _pushErrors($message); my $message = shift; push @errors, $message; return $message; } sub listErrors { # Purpose: Gets the contents of @errors # Returns: Contents of @errors # Usage: @errors = listErrors(); my ( %messages, $n, @indices ); # Filter out redundant messages $n = 0; foreach (@errors) { $messages{$_}++; push @indices, $n if $messages{$_} > 1; $n++; } foreach ( sort { $b <=> $a } @indices ) { splice @errors, $_, 1; } return @errors; } # Internal options hash my %options; sub _getOption { # Purpose: Gets the template associated with passed option # Returns: Reference to template hash or undef should the # requested option not be defined # Usage: $tref = _getOption($option); my $option = shift; return exists $options{$option} ? $options{$option} : undef; } sub _setOption { # Purpose: Associates the passed option to the passed template in # %options # Returns: True (1) # Usage: _setOption($option, $tref); my $option = shift; my $tref = shift; $options{$option} = $tref; return 1; } sub _optionsKeys { # Purpose: Returns a list of keys from %options # Returns: keys %options # Usage: @keys = _optionsKeys(); return keys %options; } sub _resetOptions { # Purpose: Empties the %options # Returns: True (1) # Usage: _resetOptions(); %options = (); return 1; } # Internal arguments list my @arguments; sub _getArgRef { # Purpose: Gets a reference the argument array # Returns: Array reference # Usage: $argRef = _getArgRef(); return \@arguments; } sub clearMemory { # Purpose: Empties all internal data structures # Returns: True (1) # Usage: clearMemory(); _NOOPTIONS = 0; _resetErrors(); _resetOptions(); @{ _getArgRef() } = (); return 1; } } sub _tLint { # Purpose: Performs basic checks on a given option template for # correctness # Returns: True (1) if all checks pass, False (0) otherwise # Usage: $rv = _tLint($templateRef); my $tref = shift; # Reference to option template hash my $rv = 1; my ( $oname, @at ); subPreamble( PDLEVEL2, '$', $tref ); # Get the option name for reporting purposes (should have been populated # within parseArgs below) $oname = $$tref{Name}; # Make sure a short or long option is declared if ( !defined $oname ) { _pushErrors('No short or long option name declared'); $rv = 0; } # Make sure the argument template is defined if ($rv) { unless ( defined $$tref{Template} ) { _pushErrors("$oname option declared without a template"); $rv = 0; } } # Make sure the template contains only supported characters if ($rv) { unless ( defined $$tref{Template} && $$tref{Template} =~ /^[\$\@]*$/s ) { _pushErrors( "$oname option declared with an invalid template" . "($$tref{Template})" ); $rv = 0; } } # Make sure option names are sane if ($rv) { if ( defined $$tref{Short} ) { unless ( $$tref{Short} =~ /^[a-zA-Z0-9]$/s ) { _pushErrors( "Invalid name for the short option ($$tref{Short})"); $rv = 0; } } if ( defined $$tref{Long} ) { unless ( $$tref{Long} =~ /^[a-zA-Z0-9-]{2,}$/s ) { _pushErrors( "Invalid name for the long option ($$tref{Long})"); $rv = 0; } } } # Make sure '@' is only used once, if at all, and the option isn't # set to allow bundling if ($rv) { if ( $$tref{Template} =~ /\@/sm ) { @at = ( $$tref{Template} =~ m#(\@)#sg ); if ( @at > 1 ) { _pushErrors( 'The \'@\' symbol can only be used once in the ' . "template for $oname: $_" ); $rv = 0; } if ( $$tref{CanBundle} and defined $$tref{Short} ) { _pushErrors( "Option $$tref{Short} must have CanBundle set to false " . 'if the template contains \'@\'' ); $rv = 0; } } } # Make sure all values in our lists are defined if ($rv) { unless ( ref( $$tref{ExclusiveOf} ) eq 'ARRAY' ) { _pushErrors( "Option ${oname}'s parameter ExclusiveOf must be an " . 'array reference' ); $rv = 0; } unless ( ref( $$tref{AccompaniedBy} ) eq 'ARRAY' ) { _pushErrors( "Option ${oname}'s parameter AccompaniedBy must be an " . 'array reference' ); $rv = 0; } if ($rv) { if ( grep { !defined } @{ $$tref{ExclusiveOf} } ) { _pushErrors( "Option $oname has undefined values in ExclusiveOf"); $rv = 0; } if ( grep { !defined } @{ $$tref{AccompaniedBy} } ) { _pushErrors( "Option $oname has undefined values in ExclusiveOf"); $rv = 0; } } } # Make sure CountShort is enabled only for those with a template of '' # or '$' if ($rv) { if ( $$tref{CountShort} ) { unless ( $$tref{Template} =~ /^\$?$/sm ) { _pushErrors( "Option $oname has CountShort set but with an " . 'incompatible template' ); $rv = 0; } } } subPostamble( PDLEVEL2, '$', $rv ); return $rv; } sub _getArgs ($$\@) { # Purpose: Takes passed argument template and extracts the requisite # arguments to satisfy it from the argument list. The # results are stored in the passed option list. # Results: True (1) if successful, False (0) if not # Usage: $rv = _getArgs($option, $argTemplate, @optionArgs); my $option = shift; # Option name my $argTemplate = shift; # Option argument template my $lref = shift; # Array reference for retrieved arguments my $rv = 1; my $argRef = _getArgRef(); my @tmp; subPreamble( PDLEVEL2, '$$$', $option, $argTemplate, $lref ); # Empty the array @$lref = (); pdebug( 'contents of args: %s', PDLEVEL4, @$argRef ); # Start checking the contents of $argTemplate if ( $argTemplate eq '' ) { # Template is '' (boolean option) @$lref = (1); } elsif ( $argTemplate =~ /\@/s ) { # Template has a '@' in it -- we'll need to # grab as many of the next arguments as possible. # Check the noOptions flags if (_NOOPTIONS) { # True: gobble up everything left push @$lref, @$argRef; @$argRef = (); } else { # False: gobble up to the next option-looking thing while ( @$argRef and $$argRef[0] !~ /^--?(?:\w+.*)?$/s ) { push @$lref, shift @$argRef; } # Now, we check to see if the first remaining argument is '--'. # If it is then we must set noOptions to true and gobble the # rest. if ( @$argRef and $$argRef[0] eq '--' ) { _NOOPTIONS = 1; shift @$argRef; push @$lref, @$argRef; @$argRef = (); } } } else { # The template is not empty and has no '@', so we'll just grab the next # n arguments, n being the length of the template # Check the noOptions flag if (_NOOPTIONS) { # True: grab everything we need while ( @$argRef and @$lref < length $argTemplate ) { push @$lref, shift @$argRef; } } else { # False: grab as many non-option-looking things as we can while ( @$argRef and $$argRef[0] !~ /^--?(?:\w+.*)$/s and @$lref < length $argTemplate ) { push @$lref, shift @$argRef; } # Now, we check to see if we still need more arguments and if # the first remaining argument is '--'. If it is then we must # set noOptions to true and gobble what we need. if ( @$lref < length $argTemplate and @$argRef and $$argRef[0] eq '--' ) { _NOOPTIONS = 1; shift @$argRef; while ( @$argRef and @$lref < length $argTemplate ) { push @$lref, shift @$argRef; } } } } # Final check: did we get minimum requisite number of arguments? if ( @$lref < length $argTemplate ) { _pushErrors( pdebug( 'Missing the minimum number of arguments for %s', PDLEVEL1, $option ) ); $rv = 0; } else { pdebug( 'extracted the following arguments: %s', PDLEVEL3, @$lref ); } # sublist '@' portions of multicharacter templates if ( $rv and $argTemplate =~ /\@/sm and length $argTemplate > 1 ) { @tmp = ( [], [], [] ); # First, shift off all preceding '$'s if ( $argTemplate =~ /^(\$+)/s ) { @{ $tmp[0] } = splice @$lref, 0, length $1; } # Next, pop off all trailing '$' if ( $argTemplate =~ /(\$+)\$/s ) { @{ $tmp[2] } = splice @$lref, -1 * length $1; } # Everything left belongs to the '@' @{ $tmp[1] } = @$lref; # Let's put it all together... @$lref = (); push @$lref, @{ $tmp[0] } if @{ $tmp[0] }; push @$lref, $tmp[1]; push @$lref, @{ $tmp[2] } if @{ $tmp[2] }; pdebug( 'sublisted arguments into: %s', PDLEVEL3, @$lref ); } subPostamble( PDLEVEL2, '$', $rv ); return $rv; } sub _storeArgs ($$\@) { # Purpose: Stores the passed option arguments in the passed option # template's Value, but in accordance with parameters in the # template # Returns: True (1) # Usage: _storeArgs($optionTemplate, $argTemplate, @optionArgs); my $tref = shift; my $argTemplate = shift; my $lref = shift; subPreamble( PDLEVEL2, '$$$', $tref, $argTemplate, $lref ); pdebug( 'adding values to %s', PDLEVEL3, $$tref{Name} ); # Increment our usage counter $$tref{Count}++; # Store arguments according to the template if ( $argTemplate eq '' ) { # Template is '' $$tref{Value} = 0 unless defined $$tref{Value}; $$tref{Value}++; pdebug( 'Value is now %s', PDLEVEL3, $$tref{Value} ); } elsif ( $argTemplate eq '$' ) { # Template is '$' if ( not $$tref{Multiple} or $$tref{CountShort} ) { # Store the value directly since we # can only be used once $$tref{Value} = $$lref[0]; pdebug( 'Value is now %s', PDLEVEL3, $$tref{Value} ); } else { # Store the value as part of a list since # we can be used multiple times $$tref{Value} = [] unless defined $$tref{Value} and ref $$tref{Value} eq 'ARRAY'; push @{ $$tref{Value} }, $$lref[0]; pdebug( 'Value is now %s', PDLEVEL3, @{ $$tref{Value} } ); } } else { # Template is anything else if ( not $$tref{Multiple} ) { # Store the values directly in a an array # since we can only be used once $$tref{Value} = [@$lref]; pdebug( 'Value is now %s', PDLEVEL3, @{ $$tref{Value} } ); } else { # Store the values as an element of an # array since we can be used multiple times $$tref{Value} = [] unless defined $$tref{Value} and ref $$tref{Value} eq 'ARRAY'; push @{ $$tref{Value} }, [@$lref]; pdebug( 'Value now has %d sets', PDLEVEL3, scalar @{ $$tref{Value} } ); } } subPostamble( PDLEVEL1, '$', 1 ); return 1; } sub parseArgs (\@\%;\@) { # Purpose: Extracts and validates all command-line arguments and options, # storing them in an organized hash for easy retrieval # Returns: True (1) if successful, False (0) if not # Usage: $rv = parseArgs(@templates, %options); # Usage: $rv = parseArgs(@templates, %options, @args); my $tlref = shift; # Templates list ref my $oref = shift; # Options hash ref my $paref = shift; # Program argument list ref my $rv = 1; my ( $tref, $oname, $argRef, $arg, $argTemplate ); my ( @tmp, @oargs, $regex ); subPreamble( PDLEVEL1, '$$$', $tlref, $oref, $paref ); # Validate arguments $paref = \@ARGV unless defined $paref; # Clear all internal data structures and reset flag clearMemory(); # Empty the passed options hash %$oref = (); # Make a copy of the argument list $argRef = _getArgRef(); @$argRef = (@$paref); # Assemble %options and lint-check the templates foreach (@$tlref) { # Make sure the element is a hash reference unless ( ref $_ eq 'HASH' ) { _pushErrors('Illegal non-hash reference in templates array'); $rv = 0; next; } # Establish a base template and copy the contents of the passed hash $tref = { Short => undef, Long => undef, Template => '', Multiple => 0, ExclusiveOf => [], AccompaniedBy => [], CanBundle => 0, CountShort => 0, Value => undef, %$_, }; # Set AllOptions for error message reporting $$tref{Name} = defined $$tref{Short} && defined $$tref{Long} ? "-$$tref{Short}/--$$tref{Long}" : defined $$tref{Short} ? "-$$tref{Short}" : defined $$tref{Long} ? "--$$tref{Long}" : undef; # Initialize our usage counter $$tref{Count} = 0; # Anything that has CountShort enabled implies Multiple/CanBundle # and a template of '$' if ( $$tref{CountShort} ) { $$tref{CanBundle} = $$tref{Multiple} = 1; $$tref{Template} = '$' if defined $$tref{Long}; } # Anything that has a Short option and a template of '$' or '' # implies CanBundle $$tref{CanBundle} = 1 if defined $$tref{Short} and $$tref{Template} eq ''; # We'll associate both the long and short options to the same hash # to make sure that we count/collect everything appropriately. # # Store the short option if ( defined $$tref{Short} and length $$tref{Short} ) { # See if a template is already defined if ( defined _getOption( $$tref{Short} ) ) { # It is -- report the error Paranoid::ERROR = _pushErrors( pdebug( 'the %s option has more than one template', PDLEVEL1, $$tref{Short} ) ); $rv = 0; } else { # It's not -- go ahead and store it _setOption( $$tref{Short}, $tref ); } } # Store the long option if ( defined $$tref{Long} and length $$tref{Long} ) { # See if a template is already defined if ( defined _getOption( $$tref{Long} ) ) { # It is -- report the error Paranoid::ERROR = _pushErrors( pdebug( 'the %s option has more than one template', PDLEVEL1, $$tref{Long} ) ); $rv = 0; } else { # It's not -- go ahead and store it _setOption( $$tref{Long}, $tref ); } } # Do a basic lint-check on the template $rv = 0 unless _tLint($tref); } if ($rv) { while (@$argRef) { $arg = shift @$argRef; next unless defined $arg; # Start testing $arg if ( $arg eq '--' and not _NOOPTIONS ) { # $arg is '--', so set the no options flag _NOOPTIONS = 1; } elsif ( not _NOOPTIONS and $arg =~ /^--?/s ) { # '--' hasn't been passed yet and this looks # like an option... # Test types of options if ( $arg =~ /^-(\w.*)$/s ) { # With a single '-' it should be a short option. However, # we'll split the option portion, in case there's more # than one character @tmp = split //s, $1; # If there's more than one character for the option name # it must be either a bunch of bundled options or an # option with a concatenated argument. In case of the # latter (assuming that CanBundle is set to false (a # prerequisite of argument concatenation) and it has a # template of '$' (another prerequisite)) we'll unshift # the rest of the characters back onto the argument list. # # Oh, but first we'll need to get the applicable # option template and then start testing... $tref = _getOption( $tmp[0] ); if ( $#tmp and defined $tref and $$tref{Template} eq '$' and not $$tref{CanBundle} ) { unshift @$argRef, join '', @tmp[ 1 .. $#tmp ]; splice @tmp, 1; } # Start processing all remaining short options in @tmp foreach (@tmp) { # Get the template $tref = _getOption($_); # Make sure the option is supported if ( defined $tref ) { # Make sure option allows bundling if bundled if ($#tmp) { unless ( $$tref{CanBundle} ) { _pushErrors( "Option $_ used bundled with " . 'other options' ); $rv = 0; next; } } # Get the argument template $argTemplate = $$tref{Template}; # Override the template if CountShort is true $argTemplate = '' if $argTemplate eq '$' and $$tref{CountShort}; # Get any accompanying arguments unless ( _getArgs( "-$_", $argTemplate, @oargs ) ) { $rv = 0; next; } # Check if we've call this more than once if ( not $$tref{Multiple} and $$tref{Count} > 0 ) { _pushErrors( "Option $$tref{Name} is only allowed " . 'to be used once' ); $rv = 0; next; } # Store the values _storeArgs( $tref, $argTemplate, @oargs ); } else { # Warn that this is an unknown option _pushErrors("Unknown short option used: $_"); $rv = 0; } } } elsif ( $arg =~ /^--([\w-]+)(?:=(.+))?$/sm ) { # Starts with '--', so must be a long option # Save the extracted option/argument portion @tmp = ($1); push @tmp, $2 if defined $2 and length $2; # If this option had an argument portion we need to # unshift it back onto the argument list *provided* it was # a legal argument, i.e., this option had a template of # '$'. $tref = _getOption( $tmp[0] ); if ( $#tmp and defined $tref ) { # Test for various templates if ( $$tref{Template} eq '$' ) { # Legal invocation -- unshift away unshift @$argRef, $tmp[1]; } elsif ( $$tref{Template} eq '' ) { # Illegal, no arguments expected _pushErrors( "--$tmp[0] does not require any " . 'arguments' ); $rv = 0; next; } else { # Illegal, can't use concatenated arguments in # more complex templates _pushErrors( "--$tmp[0] cannot be called like " . 'this when multiple arguments are ' . 'required.' ); } } # Handle known options if ( defined $tref ) { # Get the argument template $argTemplate = $$tref{Template}; # Snarf extra arguments unless ( _getArgs( "--$tmp[0]", $argTemplate, @oargs ) ) { $rv = 0; next; } # Check if we've call this more than once if ( not $$tref{Multiple} and $$tref{Count} > 0 ) { _pushErrors( "Option $$tref{Name} is only allowed to be used once" ); $rv = 0; next; } # Store the values _storeArgs( $tref, $argTemplate, @oargs ); } else { # Unknown long option _pushErrors("Unknown option: --$tmp[0]"); $rv = 0; } } else { # Unknown option-looking thingy _pushErrors("Unknown option thingy: $arg"); $rv = 0; } } else { # Everything else is payload $$oref{PAYLOAD} = [] unless exists $$oref{PAYLOAD}; push @{ $$oref{PAYLOAD} }, $arg; } } } # Make a list of all the arguments that was used @tmp = (); foreach ( _optionsKeys() ) { push @tmp, $_ if ${ _getOption($_) }{Count}; } # Final sanity check foreach ( sort @tmp ) { $tref = _getOption($_); # Make sure nothing was called that is exclusive of # other called options if ( @{ $$tref{ExclusiveOf} } ) { $regex = '(?:' . join( '|', @{ $$tref{ExclusiveOf} } ) . ')'; if ( grep /^$regex$/sm, @tmp ) { _pushErrors( "$$tref{Name} cannot be called with the following options: " . join ', ', @{ $$tref{ExclusiveOf} } ); $rv = 0; } } # Make sure the option was called in conjunction with others foreach $regex ( @{ $$tref{AccompaniedBy} } ) { unless ( grep /^\Q$regex\E$/sm, @tmp ) { _pushErrors( "$$tref{Name} must be called with the following options: " . join ', ', @{ $$tref{AccompaniedBy} } ); $rv = 0; } } # Copy the values into %$oref $$oref{$_} = $$tref{Value}; } subPostamble( PDLEVEL1, '$', $rv ); return $rv; } 1; __END__ =head1 NAME Paranoid::Args - Command-line argument parsing functions =head1 VERSION $Id: lib/Paranoid/Args.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $ =head1 SYNOPSIS use Paranoid::Args; $rv = parseArgs(@templates, %opts); $rv = parseArgs(@templates, %opts, @args); @errors = Paranoid::Args::listErrors(); Paranoid::Args::clearMemory(); =head1 DESCRIPTION The purpose of this module is to provide simplified but validated parsing and extraction of command-line arguments (otherwise known as the contents of @ARGV). It is meant to be used in lieu of modules like B and B, but that does not mean that this module is functionally equivalent -- it isn't. There are things that those modules do that this doesn't, but that's primarily by design. My priorities are a bit different when it comes to this particular task. The primary focus of this module is validation, with the secondary focus being preservation of context. =head1 IMPORT LISTS This module exports the following symbols by default: parseArgs The following specialized import lists also exist: List Members -------------------------------------------------------- template PA_DEBUG PA_VERBOSE PA_HELP PA_VERSION all @defaults @template =head2 VALIDATION When validating the use of options and arguments we concern ourselves primarily the following things: =over =item 1) Is the option accompanied by the requisite arguments? =item 2) Was the option called with the other requisite options? =item 3) Was the option called without options meant only for mutually exclusive use? =item 4) Were any unrecognized options used? =back This module also does basic sanity validation of all option templates to ensure correct usage of this module. =head2 PRESERVATION OF CONTEXT Simply put, preservation of context means remembering the order and grouping of associated arguments. Take the hypothetical case of "tagging" files. The traditional approach is to define an option that takes a single string argument and apply them to the remaining contents of @ARGV: ./foo.pl -t "tag1" file1 file2 This module supports that model, with the option argument template being '$' for that single string. But what if you wanted to apply different tags to different files with one command execution? ./foo.pl -t "tag1" file1 file2 -t "tag2" file3 In this case it is important to keep each group of payloads that you want to operate on separate. With this module you could instead use an argument template of '$@', which would return each set independently: %opt = ( 't' => [ [ "tag1", [ "file1", "file2" ] ], [ "tag2", [ "file3" ] ], ], ); Notice that we also preserve the context between the '$' and the '@' by putting the '@' arguments in a sublist. With this example that could possible be considered pointless, but we also support templates like '$$@$' which makes this very useful. Now, instead of having to shift or pop off the encapsulating arguments they now have one permanent ordinal index. You also can now just grab the array reference for the '@' portion and iterate over a complete and separate list rather than having to take a splice of the complete argument array. It's probably just me, but I find that a little easier to track. =head2 SUPPORTED COMMAND-LINE SYNTAX The following list of syntactical options are supported: =over =item o Short option bundling (i.e., "rm -rf") =item o Short option counting (i.e., "ssh -vvv") =item o Short option argument concatenation (i.e., "cut -d' '") =item o Long option "equals" argument concatenation (i.e., "./configure --prefix=/usr") =item o The use of '--' to designate all following arguments are strictly that, even if they look like options. =back This module don't support the hash key/value pairs (i.e., -s foo=one bar=two) or argument type validation (B can validate string, integer, and floating point argument types). And while it supports a short & long option it doesn't support innumerable aliases in addition. In short, if it isn't explicitly documented it isn't supported, though it probably is in B. There are a few restrictions meant to eliminate confusion: =over =item 1) Long and short argument concatenation is only allowed if the argument template is '$' (expecting a single argument, only). =item 2) Short argument concatenation is furthermore only allowed on arguments that aren't allowed to be bundled with other short options. =item 3) Short options supporting bundling can require associate arguments as long as '@' is not part of the argument template. =back =head1 SUBROUTINES/METHODS =head2 parseArgs $rv = parseArgs(@templates, %opts); $rv = parseArgs(@templates, %opts, @args); Using the option templates passed as the first reference this function populates the options hash with all of the parsed options found in the passed arguments. The args list reference can be omitted if you wish the function to work off of B<@ARGV>. Please note that this function makes a working copy of the array, so no alterations will be made to it. If any options and/or arguments fail to match the option template, or if an option is found with no template, a text message is pushed into an errors array and the function will return a boolean false. When the options hash is populated extracted arguments to the options are stored in both long and short form as the keys, assuming they were defined in the template. Otherwise it will use whatever form of option was defined. Any arguments not associated with an option are stored in the options hash in a list associated with the key B. =head2 Paranoid::Args::listErrors @errors = Paranoid::Args::listErrors(); If you need a list of everything that was found wrong during a B run, from template errors to command-line argument validation failures, you can get all of the messages form B. Please note that we show it fully qualified because it is B exported. Each time B is invoked this array is reset. =head2 Paranoid::Args::clearMemory Paranoid::Args::clearMemory(); If the existence of a (most likely) lightly populated array bothers you, you may use this function to empty all internal data structures of their contents. Like B this function is not exported. =head1 OPTION TEMPLATES The function provided by this module depends on templates to extract and validate the options and arguments. Each option template looks similar to the following: { Short => 'v', Long => 'verbose', Template => '$', CountShort => 1, Multiple => 1, CanBundle => 1, ExclusiveOf => [], AccompaniedBy => [], } This template provides extraction of verbose options in the following (and similar) forms: -vvvvv --verbose 5 --verbose=5 If B was instead false you'd have to say '-v 5' instead of '-vvvvv'. When the B function is called the options hash passed to it would be populated with: %opts = ( 'v' => 5, 'verbose' => 5, ); The redundancy is intentional. Regardless of whether you look up the short or the long name you will be able to retrieve the cumulative value. The particulars of all key/value pairs in a template are documented below. B The default template is as follows: { Short => undef, Long => undef, Template => '', Multiple => 0, ExclusiveOf => [], AccompaniedBy => [], CanBundle => 0, CountShort => 0, Value => undef, }; When creating your option templates you only need to specify those that differ from the defaults. In addition, there's a few options that are also modified automatically for you. If your template consists of a I option and has a template of I<''> then I is automatically set to true. If I is enabled then I and I is set to be true as well. Additionally, if there is a I option, the I