view release on metacpan or  search on metacpan

t/15io.t  view on Meta::CPAN

   $atomic_file = catfile( qw( t output X_atomic ) );
   $io = io( $outfile )->atomic->atomic_infix( 'X_*' )->print( 'x' );
   ok  -f $atomic_file, 'Atomic file exists - infix'; $io->close;
   ok !-e $atomic_file, 'Renames atomic file - infix';

   $atomic_file = catfile( qw( t output atomic.tmp) );
   $io = io( $outfile )->atomic->atomic_suffix( '.tmp' )->print( 'x' );
   ok  -f $atomic_file, 'Atomic file exists - suffix'; $io->close;
   ok !-f $atomic_file, 'Renames atomic file - suffix';

   my $io = io( $outfile )->atomic_infix( undef );

   is $io->_atomic_infix, 'B_*', 'Default atomic infix';
   $io->atomic_suffix( undef );
   is $io->_atomic_infix, 'B_*', 'Default atomix suffix';
   io( $outfile )->delete;
   $io = io( $outfile )->atomic->lock( LOCK_NONBLOCKING )->println( 'x' );
   io( $outfile )->close;
};

subtest 'Substitution' => sub {
   $io = io [ qw( t output substitute ) ];
   $io->println( qw( line1 line2 line3 ) );
   $io->substitute( 'line2', 'changed' );
   is( ($io->chomp->getlines( $RS ))[ 1 ], 'changed',
       'Substitutes one value for another' );
   $io->close;
   $io->substitute( 'line2' );
   is( ($io->chomp->getlines( $RS ))[ 1 ], undef, 'Substitutes null string' );
   $io->substitute( undef, 'nonono' );
   $io->substitute( q(), 'nonono' );
};

subtest 'Copy / Move' => sub {
   my $all = $io->close->all; my $to = io [ qw( t output copy ) ];

   $io->close; $io->copy( $to );
   is $to->all, $all, 'Copies a file - object target';
   $to->unlink; $io->copy( [ qw( t output copy ) ] );
   is $to->all, $all, 'Copies a file - constructs target';
   $to->unlink; $io->copy( Path::Tiny::path( "${to}" ) );
   is $to->all, $all, 'Copies a file - foreign object target';
   $io = $to; $to = io [ qw( t output object_target ) ]; $io = $io->move( $to );
   is $io->all, $all, 'Moves a file - object target';
   $to = [ qw( t output constructs_target ) ]; $io = $io->move( $to );
   is $io->all, $all, 'Moves a file - constructs target';
   $to = Path::Tiny::path( io( [ qw( t output foreign_object ) ] )->pathname );
   $io = $io->move( $to );
   is $io->all, $all, 'Moves a file - foreign object target';
};

SKIP: {
   is_ntfs and skip 'Unix ownership and permissions not applicable', 1;

   subtest 'Ownership' => sub {
      $io = io( [ qw( t output print.t ) ] );

      my $uid = $io->stat->{uid}; my $gid = $io->stat->{gid};

      eval { $io->chown( undef, $gid ) };
      like $EVAL_ERROR, qr{ \Qnot specified\E }mx,
         'Uid must be defined in chown';
      eval { $io->chown( $uid, undef ) };
      like $EVAL_ERROR, qr{ \Qnot specified\E }mx,
         'Gid must be defined in chown';
      is blessed( $io->chown( $uid, $gid ) ), 'File::DataClass::IO', 'Chown';
      eval { $io->chown( 65.534, $gid ) };
      $EFFECTIVE_USER_ID != 0 and
         like $EVAL_ERROR, qr{ \Qchown failed\E }mx, 'Chown failure';
   };

   subtest 'Permissions' => sub {
      $io = io();
      ok !$io->is_executable, 'Not executable - no name';
      ok !$io->is_link, 'Not a link - no name';
      ok !$io->is_readable, 'Not readable - no name';
      ok !$io->is_writable, 'Not writable - no name';
      $io = io( [ qw( t output print.t ) ] ); $io->print( 'one' );
      ok  $io->is_readable,   'Readable';
      ok  $io->is_writable,   'Writable';
      ok !$io->is_executable, 'Not executable';
   };

   subtest 'Changes permissions of existing file' => sub {
      $io->chmod( 0400 );
      is( (sprintf "%o", $io->stat->{mode} & 07777), '400', 'Chmod 400' );
      $io->chmod();
      is( (sprintf "%o", $io->stat->{mode} & 07777), '640', 'Chmod default' );
      $io->chmod( 0777 );
      is( (sprintf "%o", $io->stat->{mode} & 07777), '777', 'Chmod 777' );
   };

   subtest 'More permissions' => sub {
      ok $io->is_executable, 'Executable';
      $io->perms( 0 )->chmod;
      is( (sprintf "%o", $io->stat->{mode} & 07777), '0', 'Chmod 0' );
   };

   subtest 'Creates files with specified permissions' => sub {
      my $path = catfile( qw( t output print.pl ) );

      $io = io( $path, 'w', oct q(0400) )->println( 'x' );
      is( (sprintf "%o", $io->stat->{mode} & 07777), q(400), 'Create 400' );
      $io->unlink;
      $io = io( $path, 'w', oct q(0440) )->println( 'x' );
      is( (sprintf "%o", $io->stat->{mode} & 07777), q(440), 'Create 440' );
      $io->unlink;
      $io = io( $path, 'w', oct q(0600) )->println( 'x' );
      is( (sprintf "%o", $io->stat->{mode} & 07777), q(600), 'Create 600' );
      $io->unlink;
      $io = io( $path, 'w', oct q(0640) )->println( 'x' );
      is( (sprintf "%o", $io->stat->{mode} & 07777), q(640), 'Create 640' );
      $io->unlink;
      $io = io( $path, 'w', oct q(0644) )->println( 'x' );
      is( (sprintf "%o", $io->stat->{mode} & 07777), q(644), 'Create 644' );
      $io->unlink;
      $io = io( $path, 'w', oct q(0664) )->println( 'x' );
      is( (sprintf "%o", $io->stat->{mode} & 07777), q(664), 'Create 664' );
      $io->unlink;
      $io = io( $path, 'w', oct q(0666) )->println( 'x' );
      is( (sprintf "%o", $io->stat->{mode} & 07777), q(666), 'Create 666' );
      $io->unlink;
      $io = io( $path )->perms( oct q(0640) )->println( 'x' );
      is( (sprintf "%o", $io->stat->{mode} & 07777), q(640),
          'Create using prefered syntax' );
      $io->unlink;
   };
}