From adb450b7641878a87f672ff0b52b3232389a456d Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Mon, 10 Dec 2007 00:17:43 +0000 Subject: [PATCH] Made a bit of cleanup with perlcritic git-svn-id: file:///home/poletti/.svk/local/perl/deployable/trunk@1415 c4a4780d-4107-0410-9bb9-83707a6d5e2d --- deployable | 55 ++++++++++++++++++++++++++++++++----------------------- remote | 41 +++++++++++++++++++++++------------------ 2 files changed, 55 insertions(+), 41 deletions(-) diff --git a/deployable b/deployable index 2e07d6b..70171f3 100755 --- a/deployable +++ b/deployable @@ -2,9 +2,10 @@ use strict; use warnings; use Carp; +use version; our $VERSION = qv('0.0.1'); +use Fatal qw( close ); use Pod::Usage qw( pod2usage ); use Getopt::Long qw( :config gnu_getopt ); -use version; my $VERSION = qv('0.0.1'); use English qw( -no_match_vars ); use File::Basename qw( basename dirname ); use File::Spec::Functions qw( file_name_is_absolute catfile ); @@ -21,8 +22,8 @@ use Cwd qw( realpath ); # Log::Log4perl->easy_init($INFO); my %config = ( - output => '-', - remote => catfile(dirname(realpath(__FILE__)), 'remote'), + output => '-', + remote => catfile(dirname(realpath(__FILE__)), 'remote'), ); GetOptions( \%config, 'usage', @@ -40,7 +41,7 @@ pod2usage(-verbose => 99, -sections => 'USAGE|EXAMPLES|OPTIONS') pod2usage(-verbose => 2) if $config{man}; pod2usage( - message => "working directory must be an absolute path", + message => 'working directory must be an absolute path', -verbose => 99, -sections => '' ) @@ -48,8 +49,8 @@ pod2usage( my $out_fh = \*STDOUT; if ($config{output} ne '-') { - open my $fh, '>', $config{output} - or die "open('$config{output}'): $OS_ERROR"; + open my $fh, '>', $config{output} ## no critic + or croak "open('$config{output}'): $OS_ERROR"; $out_fh = $fh; } @@ -61,11 +62,12 @@ print {$out_fh} get_remote_script(); print {$out_fh} '#' x 72, "\n# General configurations\n\n"; for my $name (qw( workdir cleanup )) { print {$out_fh} confline($name, $config{$name}), "\n\n" - if exists $config{$name}; + if exists $config{$name}; } # Emit list of deploy scripts -print {$out_fh} confline('deploy@', $_), "\n\n" for @{ $config{deploy} || [] }; +print {$out_fh} confline('deploy@', $_), "\n\n" + for @{$config{deploy} || []}; # Time for tarfiles now print {$out_fh} '#' x 72, "\n# List of files\n[files]\n\n"; @@ -74,7 +76,7 @@ print {$out_fh} '#' x 72, "\n# List of files\n[files]\n\n"; # extraction directory, i.e. basename() will be applied to them. For # directories, they will be re-created for my $file (@ARGV) { - die "'$file' not readable" unless -r $file; + croak "'$file' not readable" unless -r $file; if (-d $file) { print {*STDERR} "processing directory '$file'\n"; print {$out_fh} as_comment("directory $file, extracted into:"), "\n"; @@ -83,8 +85,8 @@ for my $file (@ARGV) { } ## end if (-d $file) else { print {*STDERR} "processing file '$file'\n"; - my $mode = sprintf "0%lo", (stat $file)[2] & 07777; - print {$out_fh} as_comment("file saves both mode and filename"), + my $mode = sprintf '0%lo', (stat $file)[2] & oct(7777); + print {$out_fh} as_comment('file saves both mode and filename'), "\n"; print {$out_fh} confline('file', $mode . ' ' . basename($file)), "\n"; @@ -94,9 +96,9 @@ for my $file (@ARGV) { # Tarfiles are files that will be extracted in the target directory for my $tarfile (@{$config{tarfile}}) { - die "'$tarfile' not readable" unless -r $tarfile; + croak "'$tarfile' not readable" unless -r $tarfile; print {*STDERR} "processing tarfile '$tarfile'\n"; - print {$out_fh} as_comment("tarfile will also be extracted into ."), + print {$out_fh} as_comment('tarfile will also be extracted into .'), "\n"; print {$out_fh} confline(tarfile => $tarfile), "\n"; save_file($tarfile, $out_fh); @@ -104,7 +106,7 @@ for my $tarfile (@{$config{tarfile}}) { # Heredirs are directories that are extracted directly into the ex dir for my $heredir (@{$config{heredir}}) { - die "'$heredir' not readable" unless -r $heredir; + croak "'$heredir' not readable" unless -r $heredir; print {*STDERR} "processing here-directory '$heredir'\n"; print {$out_fh} as_comment("here-directory = $heredir, extracted into:"), "\n"; @@ -113,22 +115,28 @@ for my $heredir (@{$config{heredir}}) { } ## end for my $heredir (@{$config... close $out_fh; -chmod 0755, $config{output} if $config{output} ne '-'; +if ($config{output} ne '-') { + chmod oct(755), $config{output} + or carp "chmod(0755, '$config{output}'): $OS_ERROR"; +} sub save_directory { my ($changedir, $filename, $out_fh) = @_; + ## no critic open my $fh, '-|', '/bin/tar', 'czf', '-', '-b', '1', '-C', $changedir, $filename, - or die "open() for /bin/tar: $OS_ERROR"; + or croak "open() for /bin/tar: $OS_ERROR"; return hexified_copy($fh, $out_fh); } ## end sub save_directory sub save_file { my ($filename, $out_fh) = @_; + + ## no critic open my $fh, '<', $filename - or die "open('$filename'): $OS_ERROR"; + or croak "open('$filename'): $OS_ERROR"; return hexified_copy($fh, $out_fh); } ## end sub save_file @@ -142,25 +150,26 @@ sub hexified_copy { return; } ## end sub hexified_copy -sub as_comment { - return join "\n", map { '# ' . $_ } map { split /\n/ } @_; +sub as_comment { ## no critic + return join "\n", map { '# ' . $_ } map { split /\n/mxs } @_; } sub confline { my ($name, $data) = @_; my $comment = "$name = $data"; - my $line = join ' = ', $name, unpack('H*', $data); + my $line = join ' = ', $name, unpack 'H*', $data; return join "\n", as_comment("$name = $data"), $line; } ## end sub confline sub get_remote_script { open my $fh, '<', $config{remote} - or die "open('$config{remote}'): $OS_ERROR"; + or croak "open('$config{remote}'): $OS_ERROR"; my @lines; while (<$fh>) { - last if /\A__END__\s*\z/; + last if /\A __END__ \s*\z/mxs; push @lines, $_; } + close $fh; return join '', @lines, "__END__\n"; } ## end sub get_remote_script @@ -539,7 +548,7 @@ Please report any bugs or feature requests to the AUTHOR below. Flavio Poletti C -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2006, Flavio Poletti C. All rights reserved. diff --git a/remote b/remote index 62cfa8b..78cc12c 100755 --- a/remote +++ b/remote @@ -2,7 +2,7 @@ use strict; use warnings; use 5.006_002; -my $VERSION = '0.0.1'; +our $VERSION = '0.0.1'; use English qw( -no_match_vars ); use Fatal qw( close chdir mkdir ); use File::Temp qw( tempdir ); @@ -63,7 +63,7 @@ if (@directories) { print {*STDERR} "### Got into working directory '$config{workdir}'\n\n"; my $tempdir; -if (!$config{'no-tempdir'}) { # Only if not prohibited +if (!$config{'no-tempdir'}) { # Only if not prohibited my $now = strftime('%Y-%m-%d_%H-%M-%S', localtime); $tempdir = tempdir($now . 'X' x 10, DIR => '.', CLEANUP => $config{cleanup}); @@ -75,7 +75,7 @@ if (!$config{'no-tempdir'}) { # Only if not prohibited print {*STDERR} "\n"; } ## end if (!$config{'no-tempdir'... -eval { # Not really needed, but you know... +eval { # Not really needed, but you know... $ENV{PATH} = '/bin:/usr/bin:/sbin:/usr/sbin'; save_files(); execute_deploy_programs(); @@ -102,25 +102,25 @@ sub execute_deploy_programs { } ## end sub execute_deploy_programs { - my ($last, $getlast); - sub unget_DATA_line { $getlast = 1 } + my ($last_line, $getlast); + sub unget_DATA_line { return $getlast = 1 } sub get_DATA_line { if (!$getlast) { - if (defined($last = )) { - $last =~ s/#.*//; - $last =~ s/\s+//g; + if (defined($last_line = )) { + $last_line =~ s/\#.*//mxs; + $last_line =~ s/\s+//gmxs; } } ## end if (!$getlast) $getlast = 0; # reset the flag anyway - return $_ = $last; + return $_ = $last_line; } ## end sub get_DATA_line } sub skip_DATA_spaces { - local $_; - while (defined get_DATA_line()) { last if /\S/ } - unget_DATA_line(); + local $_ = undef; + while (defined get_DATA_line()) { last if /\S/mxs } + return unget_DATA_line(); } sub get_config { @@ -130,7 +130,7 @@ sub get_config { next unless length $_; last if $_ eq '[files]'; - my ($name, $value) = split /=/, $_; + my ($name, $value) = split /=/mxs, $_; $value = pack 'H*', $value; if (substr($name, -1) eq '@') { @@ -150,12 +150,12 @@ sub save_files { while (defined get_DATA_line()) { next unless length $_; - my ($tag, $filename) = split /\s*=\s*/, $_; + my ($tag, $filename) = split /\s* = \s*/mxs, $_; # Un-hexify and ensure it's written in the current directory $filename = pack 'H*', $filename; my $mode; - ($mode, $filename) = split /\s+/, $filename, 2 if $tag eq 'file'; + ($mode, $filename) = split /\s+/mxs, $filename, 2 if $tag eq 'file'; $filename = basename($filename); print {*STDERR} "### Working on $tag '$filename'\n"; @@ -180,22 +180,27 @@ sub save_files { } ## end while (defined get_DATA_line... close $_ for @fhs; - chmod oct($mode), $filename if $tag eq 'file'; + if ($tag eq 'file') { + chmod oct($mode), $filename + or carp "chmod(0$mode, '$filename'): $OS_ERROR"; + } print {*STDERR} "\n"; } ## end while (defined get_DATA_line... + + return; } ## end sub save_files sub output_fh { my ($filename) = @_; - open my $fh, '>', $filename or die "open('$filename'): $OS_ERROR"; + open my $fh, '>', $filename or croak "open('$filename'): $OS_ERROR"; binmode $fh; return $fh; } ## end sub output_fh sub pipe_to_tar { open my $fh, '|-', '/bin/tar', 'xvzf', '-', '--no-same-owner', '--touch' - or die "open() for /bin/tar: $OS_ERROR"; + or croak "open() for /bin/tar: $OS_ERROR"; binmode $fh; return $fh; } ## end sub pipe_to_tar -- 2.11.4.GIT