Merge pull request #243 from stdweird/writer_def_perms

FileWriter: Handle default permissions

src/main/perl/FileWriter.pm

@@ -8,9 +8,11 @@ use Errno qw(ENOENT);
 use IO::String;
 use CAF::Process;
 use CAF::Object;
+use CAF::Path;
+use File::Basename qw(dirname);
 use overload '""' => "stringify";
 
-our @ISA = qw (IO::String);
+use parent qw(IO::String);
 
 our $_EC = LC::Exception::Context->new()->will_store_errors();
 
@@ -146,7 +148,7 @@ sub new
     *$self->{LOG} = $opts{log} if exists ($opts{log});
     *$self->{LOG}->verbose ("Opening file $path") if exists (*$self->{LOG});
 
-    *$self->{options}->{mode} = $opts{mode} if exists ($opts{mode});
+    *$self->{options}->{mode} = exists($opts{mode}) ? $opts{mode} : oct(644);
     *$self->{options}->{owner} = $opts{owner} if exists ($opts{owner});
     *$self->{options}->{group} = $opts{group} if exists ($opts{group});
     *$self->{options}->{mtime} = $opts{mtime} if exists ($opts{mtime});
@@ -288,7 +290,7 @@ sub close
 
         # Update event metadata with diff
         $event{changed} = $changed;
-        if ($changed && ! *$self->{options}->{sensitive}) {
+        if ($changed && ! $options->{sensitive}) {
             $event{diff} = $diff
         }
 
@@ -301,10 +303,22 @@ sub close
                 $msg = 'would have been';
                 $self->debug(1, "File $filename with NoAction=1");
             } else {
+                my $parent_dir = dirname($filename);
+                # Pass NoAction here, as it keeps track of the NoAction value during initialisation and/or keeps_state
+                my $cafpath = CAF::Path::mkcafpath(log => *$self->{LOG}, NoAction => $options->{noaction});
+                # only create the directory if it didn't exist yet
+                # if not, this would change the directory mode on existing directories
+                if (!$cafpath->directory_exists($parent_dir) &&
+                    !$cafpath->directory($parent_dir, mode => oct(755))) {
+                    my $msg = "Failed to make parent directory $parent_dir:$cafpath->{fail}";
+                    $self->warn($msg);
+                    throw_error("close AtomicWrite failed filename $filename: $msg");
+                    return;
+                }
+
                 my $opts = {
                     file => $filename,
                     input => $content_ref,
-                    MKPATH => 1, # create missing parent directory
                 };
                 # group is handled separately
                 foreach my $name (qw(mode mtime backup owner)) {
@@ -321,6 +335,7 @@ sub close
                     $self->warn("AtomicWrite gave error: $@");
                     # Make an oldstyle exception
                     throw_error("close AtomicWrite failed filename $filename: $@");
+                    return;
                 }
 
                 # Restore the SELinux context in case of modifications.

src/main/perl/Path.pm

@@ -83,6 +83,50 @@ undef on failure and store the error message in the C<fail> attribute.
 
 =back
 
+=head2 Functions
+
+=over
+
+=item mkcafpath
+
+Returns an instance of C<CAF::Object> and C<CAF::Path>.
+This instance is a simple way to use C<CAF::Path> when
+subclassing is not possible. Allowed options are
+C<<log => $logger>> and C<<NoAction => $noaction>>.
+
+This function is not exported, to be used as e.g.
+    use CAF::Path;
+    ...
+    my $cafpath = CAF::Path::mkcafpath(log => $logger);
+    if(! defined($cafpath->directory($name)) {
+        $logger->error("Failed to make directory $name: $cafpath->{fail}");
+    };
+
+=cut
+
+sub mkcafpath
+{
+    # Internal class/package/namespace; limited to the scope of the block
+    {
+        package __caf_path_object;
+        use parent qw(CAF::Object CAF::Path);
+        sub _initialize ## no critic (Subroutines::ProhibitNestedSubs)
+        {
+            my ($self, %opts) = @_;
+            foreach my $optname (qw(log NoAction)) {
+                $self->{$optname} = $opts{$optname} if exists $opts{$optname};
+            };
+            return CAF::Object::SUCCESS;
+        };
+    }
+
+    return __caf_path_object->new(@_);
+}
+
+=pod
+
+=back
+
 =head2 Methods
 
 =over
@@ -865,4 +909,5 @@ sub move
 
 =cut
 
+
 1;

src/test/perl/fileeditor.t

@@ -25,6 +25,10 @@ $mockapp->mock('error', sub {
     diag "[ERROR] $text\n";
 });
 
+my $mock_path = Test::MockModule->new('CAF::Path');
+# parent dir always exists
+$mock_path->mock('directory_exists', sub {return 1;});
+
 use Test::Quattor::Object;
 
 my $obj = Test::Quattor::Object->new();
@@ -105,7 +109,6 @@ is_deeply(\%opts, {
     mtime => 1234567,
     contents => TEXT."another line\n",
     file => $filename,
-    MKPATH => 1,
 }, "options set in new() and current contents are passed to File::AtomicWrite");
 
 is(*$fh->{filename}, $filename, "The object stores its parent's attributes");
@@ -121,7 +124,7 @@ isa_ok ($fh, "CAF::FileEditor", "Correct class after open method");
 isa_ok ($fh, "CAF::FileWriter", "Correct class inheritance after open method");
 $fh->close();
 diag "keeps_state + noaction=1 ", explain \%opts;
-is_deeply([sort keys %opts], [qw(MKPATH contents file input)], "noaction=1 with keeps_state calls File::AtomicWrite::write_file");
+is_deeply([sort keys %opts], [qw(contents file input mode)], "noaction=1 with keeps_state calls File::AtomicWrite::write_file");
 
 
 $fh = CAF::FileEditor->open($filename);

src/test/perl/filewriter-notmocked.t

@@ -30,6 +30,8 @@ use Readonly;
 
 Readonly my $TEXT => "test\n";
 
+sub get_perm {(stat($_[0]))[2] & 07777;};
+
 my ($fn, $fh);
 
 my $testdir = 'target/test/writer-notmocked';
@@ -75,8 +77,7 @@ is_deeply($obj->{LOGLATEST}->{EVENT}, {
 # test content
 is(readfile($fn), $TEXT, "file $fn created with expected contents");
 # stat test mtime, mode
-my $mode = (stat($fn))[2] & 07777;
-is($mode, 0764, "created file $fn has mode 0764");
+is(get_perm($fn), 0764, "created file $fn has mode 0764");
 is((stat($fn))[9], 1234567, "mtime set to 1234567 forfile $fn");
 
 # test with existing file
@@ -92,6 +93,48 @@ like($obj->{LOGLATEST}->{EVENT}->{diff},
      qr{@@ -1 \+1 @@\n-garbage(\n\\ No newline at end of file\n)?\+test\n},
      "event diff on close");
 
+# verify LC::Check behaviour
+# if we ever get rid of LC, the LC part of the test can be removed
+
+# force mask
+#   so do not use mkpath from File::Path as AtomicWrite does
+# For now, test with ncm-ncd mask
+# TODO: test restrictive mask (see CAF #242)
+my $oldmask = umask 022;
+
+my $defdirperm = 0755;
+my $deffileperm = 0644;
+
+my $pdir = "$testdir/success_lc";
+ok(! -d $pdir, "parent dir $pdir doesn't exist for LC");
+my $pdir2 = "$pdir/level2";
+ok(! -d $pdir2, "2nd level parent dir $pdir2 doesn't exist for LC");
+$fn = "$pdir2/file1";
+use LC::Check;
+LC::Check::file($fn, contents=>"a");
+# check permisssions on file and subdir
+is(get_perm($fn), $deffileperm, "LC created file $fn has default mode 0644");
+is(get_perm($pdir), $defdirperm, "LC created parentdir $pdir has default mode 0755");
+is(get_perm($pdir2), $defdirperm, "LC created 2nd level parentdir $pdir has default mode 0755");
+
+
+$pdir = "$testdir/success_fw";
+ok(! -d $pdir, "parent dir $pdir doesn't exist");
+$pdir2 = "$pdir/level2";
+ok(! -d $pdir2, "2nd level parent dir $pdir2 doesn't exist");
+$fn = "$pdir2/file1";
+$fh = CAF::FileWriter->open ($fn, log => $obj);
+print $fh $TEXT;
+$fh->close();
+
+# check permisssions on file and subdir
+is(get_perm($fn), $deffileperm, "created file $fn has default mode 0644");
+is(get_perm($pdir), $defdirperm, "created parentdir $pdir has default mode 0755");
+is(get_perm($pdir2), $defdirperm, "created 2nd level parentdir $pdir has default mode 0755");
+
+# restore mask
+umask $oldmask;
+
 # test failure
 ok(! $EC->error(), "No previous error before failure check");
 
@@ -111,4 +154,6 @@ like($EC->error->text, qr{^close AtomicWrite failed filename target/test/writer-
      "message from die converted in exception");
 $EC->ignore_error();
 
+
+
 done_testing();

src/test/perl/filewriter.t

@@ -53,7 +53,7 @@ use constant FILENAME => "/my/test";
 our ($path, $text, $text_throw, $text_from_file, $faw_die);
 our %opts = ();
 
-my $log;
+my ($log, $dir_exists, $dir_args, $dir_ec);
 my $str = '';
 open ($log, ">", \$str);
 
@@ -72,9 +72,20 @@ sub init_test
     close($log);
     $str = '';
     open ($log, ">", \$str);
+    $dir_exists = 0;
+    $dir_args = undef;
+    $dir_ec = 1;
 }
 
 my $mock_history = Test::MockModule->new('CAF::History');
+my $mock_path = Test::MockModule->new('CAF::Path');
+$mock_path->mock('directory', sub {
+    my $self = shift;
+    $dir_args = \@_;
+    $self->{fail} = "directory failed" if !$dir_ec;
+    return $dir_ec;
+});
+$mock_path->mock('directory_exists', sub {$dir_exists++; return 0;});
 
 use CAF::FileWriter;
 
@@ -91,8 +102,11 @@ ok (*$fh->{save}, "File marked to be saved");
 $fh->close();
 is ($opts{contents}, TEXT, "The file has the correct contents");
 is ($opts{mode}, 0600, "The file is created with the correct permissions");
+ok (!defined($opts{MKPATH}), "The file is created without MKPATH");
 ok (!*$fh->{save},  "File marked not to be saved after closing");
 is ($path, FILENAME, "The correct file is opened");
+is($dir_exists, 1, "directory exists called once");
+is_deeply($dir_args, ['/my', 'mode', 0755], "directory creation called with parent dir args");
 
 my @methods = qw(info verbose report debug warn error event is_verbose);
 foreach my $method (@methods) {
@@ -214,6 +228,7 @@ $text = TEXT;
 $fh = CAF::FileWriter->new (FILENAME, log => $this_app);
 print $fh TEXT;
 $fh->close();
+is_deeply(\%opts, {}, "no modification, no call to file_write");
 $re = "File " . FILENAME . " was not modified";
 like($str, qr{^$re}m, "Writing same contents correctly reported");
 
@@ -225,6 +240,7 @@ $fh->close();
 $re = "File " . FILENAME . " was modified";
 like($str, qr{^$re}m, "Open/close file correctly reported");
 is($opts{contents}, '', "Open/close file resets content");
+is ($opts{mode}, 0644, "Checking options: correct default mode passed");
 
 
 $CAF::Object::NoAction = 1;
@@ -393,4 +409,23 @@ like($EC->error->text, qr{^close AtomicWrite failed filename /my/test: File::Ato
      "message from die converted in exception");
 $EC->ignore_error();
 
+init_test();
+ok(! $EC->error(), "No previous error before failure check");
+$dir_ec = 0;
+$fh = CAF::FileWriter->open (FILENAME, log => $obj);
+print $fh TEXT;
+$fh->close();
+ok($EC->error(), "old-style exception thrown on directory failure");
+like($EC->error->text, qr{^close AtomicWrite failed filename /my/test: Failed to make parent directory /my:directory failed},
+     "fail attribute from directory converted in exception");
+$EC->ignore_error();
+
+init_test();
+ok(! $EC->error(), "No previous error before failure check");
+$dir_ec = 0;
+is($this_app->err_mkfile(FILENAME, 'something'),
+   'close AtomicWrite failed filename /my/test: Failed to make parent directory /my:directory failed',
+   'err_mkfile handles error throwing');
+ok(! $EC->error(), "No error before err_mkfile");
+
 done_testing();

src/test/perl/modules/testapp.pm

@@ -18,6 +18,9 @@ use CAF::Application;
 use LC::Exception qw (SUCCESS);
 
 use CAF::History;
+use CAF::FileWriter;
+
+our $EC = LC::Exception::Context->new()->will_store_errors();
 
 our @ISA = qw(CAF::Application);
 
@@ -62,4 +65,20 @@ sub debug
     diag "[DEBUG] $lvl $text\n";
 }
 
+# Test old-style error throwing/catching
+sub err_mkfile
+{
+    my ($self, $filename, $txt) = @_;
+    my $fh = CAF::FileWriter->new($filename);
+    print $fh $txt;
+    $fh->close();
+
+    my $ret;
+    if ($EC->error()) {
+        $ret = $EC->error->text;
+        $EC->ignore_error;
+    }
+    return $ret
+}
+
 1;

src/test/perl/path.t

@@ -1096,4 +1096,13 @@ is($nrfiles, 2, "$nrfiles files in dest dir after move NoAction=1");
 # reenable NoAction
 $CAF::Object::NoAction = 1;
 
+=head2 mkcafpath
+
+=cut
+
+my $inst = CAF::Path::mkcafpath(log => $obj);
+isa_ok($inst, 'CAF::Object', "mkcafpath returns CAF::Object instance");
+isa_ok($inst, 'CAF::Path', "mkcafpath returns CAF::Path instance");
+is($inst->{log}, $obj, "log attribute set");
+
 done_testing();

src/test/perl/rbe_build_line_pattern.t

@@ -160,6 +160,7 @@ $escaped_pattern = $fh->_buildLinePattern($KEYWORD,
                                           $VALUE_1);
 is($escaped_pattern, $EXPECTED_PATTERN_SETENV_EQUAL, "'setenv=keyword value': pattern ok");
 
+$fh->close();
 
 # Test::NoWarnings::had_no_warnings();
 

src/test/perl/rbe_format_config_line.t

@@ -123,3 +123,5 @@ $line = $rbe_fh->_formatConfigLine($KEYWORD_SIMPLE, $VALUE_STR, LINE_FORMAT_ENV_
 is($line, 'export '.$EXPECTED_SH_VAR_SIMPLE, 'Environment variable: LINE_OPT_SEP ignored');
 $line = $rbe_fh->_formatConfigLine($KEYWORD_SIMPLE, '', LINE_FORMAT_ENV_VAR, 0);
 is($line, 'export '.$EXPECTED_SH_VAR_EMPTY, 'Environment variable with empty value properly formatted');
+
+$rbe_fh->close();

src/test/perl/rbe_value_format.t

@@ -206,5 +206,6 @@ $formatted_value = $rbe_fh->_formatAttributeValue(\%STRING_HASH,
 # if the value cannot be interpolated as a string
 ok(! defined($formatted_value), "A hash passed as value cannot be interpolated as a string");
 
+$rbe_fh->close();
 
 Test::NoWarnings::had_no_warnings();