File Coverage

blib/lib/Mozilla/Backup/Plugin/FileCopy.pm

Criterion	Covered	Total	%
statement	27	163	16.5
branch	0	64	0.0
condition	0	20	0.0
subroutine	9	24	37.5
pod	10	10	100.0
total	46	281	16.3

=head1 NAME

Mozilla::Backup::Plugin::FileCopy - A file copy plugin for Mozilla::Backup

=begin readme

=head1 REQUIREMENTS

The following non-core modules are required:

  File::Copy;
  Log::Dispatch;
  Mozilla::Backup
  Mozilla::ProfilesIni;
  Params::Smart
  Return::Value;

=end readme

=head1 SYNOPSIS

  use Mozilla::Backup;

  my $moz = Mozilla::Backup->new(
    plugin => 'Mozilla::Backup::Plugin::FileCopy'
  );


=head1 DESCRIPTION

This is a plugin for Mozilla::Backup which copies profiles to another
directory.

=over

=cut

package Mozilla::Backup::Plugin::FileCopy;

use strict;

use Carp;
use File::Copy;
use File::Find;
use File::Spec;
use Log::Dispatch;
use Mozilla::ProfilesIni;
use Params::Smart 0.04;
use Return::Value;

# require Mozilla::Backup;

# $Revision: 1.16 $

our $VERSION = '0.03';

=item new

  $plugin = Mozilla::Backup::Plugin::FileCopy->new( %options );

The following C<%options> are supported:

=over

=item log

The L objetc used by L. This is required.

=item debug

The debug flag from L. This is not used at the moment.

=back

=cut

# TODO - option to preserve file perms/ownership, which should be
# enabled by default.  Possibly specify a callback to run on each
# copied file?

my @ALLOWED_OPTIONS = (
   {
     name     => "log",
     default  => Log::Dispatch->new(),
     callback => sub {
       my ($self, $name, $log) = @_;
       croak "invalid log sink"
	 unless ((ref $log) && $log->isa("Log::Dispatch"));
       return $log;
     },
     name_only => 1,
     required  => 1,
   },
   {
     name      => "debug",
     default   => 0,
     name_only => 1,
   },
);

sub new {
  my $class = shift || __PACKAGE__;
  my %args  = Params(@ALLOWED_OPTIONS)->args(@_);

  my $self  = {
    log       => $args{log},
    debug     => $args{debug},
    status    => "closed",
  };

  return bless $self, $class;
}

=item allowed_options

  @options = Mozilla::Backup::Plugin::FileCopy->allowed_options();

  if (Mozilla::Backup::Plugin::FileCopy->allowed_options('debug')) {
    ...
  }

If no arguments are given, it returns a list of configuration parameters
that can be passed to the constructor.  If arguments are given, it returns
true if all of the arguments are allowable options for the constructor.

=cut

sub allowed_options {
  my $class = shift || __PACKAGE__;
  my %args = Params(qw( ?*options ))->args(@_);

  my %allowed = map { $_->{name} => 1, } @ALLOWED_OPTIONS;

  my @opts = @{$args{options}}, if ($args{options});
  if (@opts) {
    my $allowed = 1;
    while ($allowed && (my $opt = shift @opts)) {
      $allowed = $allowed && $allowed{$opt};
    }
    return $allowed;
  }
  else {
    return (keys %allowed);
  }
}

=item munge_location

  $directory = $plugin->munge_location( $directory );

Munges the backup location name for use by this plugin. (Currently
has no effect.)

=cut

sub munge_location {
  my $self = shift;
  my %args = Params(qw( file ))->args(@_);
  my $file = $args{file} || "";
  return $file;
}

=item open_for_backup

  if ($plugin->open_for_backup( $filename, %options )) {
    ...
  }

Creates a new archive for backing the profile. C<$filename> is the
name of the archive file to be used. C<%options> are optional
configuration parameters.

=cut

sub open_for_backup {
  my $self = shift;
  my %args = Params(qw( path ?*options ))->args(@_);

  unless ($self->{status} eq "closed") {
    return failure $self->_log(
      "cannot create archive: status is \"$self->{status}\"" );
  }

  my $path = File::Spec->rel2abs($args{path});

  $self->{opts} = $args{options};

  $self->_log( level => "debug", message => "creating archive $path\n" );

  mkdir $path;
  chmod 0700, $path;
  if ($self->{path} = _catdir($path)) {
    $self->{status} = "open for backup";
    return success;
  }
  else {
    return failure $self->_log(
      "unable to create path: \"$path\"", );
  }

}

=item open_for_restore

  if ($plugin->open_for_restore( $filename, %options )) {
    ...
  }

Opens an existing archive for restoring the profile.

=cut

sub open_for_restore {
  my $self = shift;
  my %args = Params(qw( path ?*options ))->args(@_);

  unless ($self->{status} eq "closed") {
    return failure $self->_log(
      "cannot open archive: status is \"$self->{status}\"" );
  }

  my $path = File::Spec->rel2abs($args{path});

  if ($self->{path} = _catdir($path)) {
    $self->{status} = "open for restore";
    return success;
  }
  else {
    return failure $self->_log( "cannot find archive: \"$path\"" );
  }
}

=item get_contents

  @files = $plugin->get_contents;

Returns a list of files in the archive.

=cut

sub get_contents {
  my $self = shift;

  unless ($self->{status} ne "closed") {
    return failure $self->_log(
      "cannot get contents: status is \"$self->{status}\"" );
  }

  my $path  = $self->{path};
  my @files = ( );

  find({
	bydepth    => 1,
	wanted     => sub {
	  my $file = $File::Find::name;
	  my $name = substr($file, length($path));
	  if ($name) {
	    $name = substr($name,1); # remove initial '/'
	    {
	      $name .= '/' if (-d $file);
	      push @files, $name;
	    }
	  }

	},
       }, $path
      );

  unless (@files) {
    carp $self->_log( level => "warn",
      message => "no files in backup" );
  }

  return @files;
}

=item backup_file

  $plugin->backup_file( $local_file, $internal_name );

Backs up the file in the archive, using C<$internal_name> as the
name in the archive.

=cut

sub backup_file {
  my $self = shift;
  my %args = Params(qw( file ?internal  ))->args(@_);

  unless ($self->{status} eq "open for backup") {
    return failure $self->_log(
      "cannot backup file: status is \"$self->{status}\"" );
  }

  my $file = File::Spec->canonpath($args{file}); # actual file
  my $name = $args{internal} || $file;    # name in archive

  $self->_log( level => "info", message => "backing up $name\n" );

  if (-d $file) {
    my $dest = File::Spec->catdir($self->{path}, $name);
    if ($self->_create_dir($name)) {
      $self->_log( level => "debug", message => "creating $dest\n" );
      mkdir $dest;
      chmod 0700, $dest;
    }
    return failure "directory $dest not found" unless (_catdir($dest));
    return success;
  } elsif (-r $file) {
    my $dest = File::Spec->catfile($self->{path}, $name);
    if ($self->_create_dir($name)) {
      $self->_log( level => "debug",
         message => "copying $file to $dest\n" );

      # TODO - options to copy permissions

      copy($file, $dest)
	|| return failure $self->_log( "copying failed: $!" );
    }
    return failure "file $dest not found" unless (_catfile($dest));
    return success;
  } else {
    return failure $self->_log( "cannot find file $file" );
  }
}

=begin internal

=item _create_dir

  if ($plugin->_create_dir($name, $root)) {
    ...
  }

Creates deep directories. (This may be removed in future versions.)

=end internal

=cut

sub _create_dir {
  my $self = shift;
  my $name = shift;
  my $root = shift || $self->{path};

  my @dirs = File::Spec->splitdir($name);
  my $file = pop @dirs;

  foreach my $dir ("", @dirs) {
    $root = File::Spec->catdir($root, $dir);
    unless (-d $root) {
      $self->_log( level => "debug", message => "creating $root\n" );
      mkdir $root;
      chmod 0700, $root;
    }
  }
  return _catdir($root) ? $file : undef;
}


=item restore_file

  $plugin->restore_file( $internal_name, $local_file );

Restores the file from the archive.

=cut

sub restore_file {
  my $self = shift;
  my %args = Params(qw( internal file ))->args(@_);

  unless ($self->{status} eq "open for restore") {
    return failure $self->_log(
      "cannot restore file: status is \"$self->{status}\"" );
  }

  my $file = $args{internal};
  my $dest = $args{file} ||
    return failure $self->_log( "no destination specified" );

  unless (-d $dest) {
    return failure $self->_log( "destination does not exist" );
  }

  my $path = File::Spec->catfile($dest, $file);
  if (-e $path) {
    $self->_log( level => "debug", message => "$path exists\n" );
    # TODO: confirmation to overwrite?
  }

  $self->_log( level => "info", message => "restoring $file\n" );

  my $src = File::Spec->catfile($self->{path}, $file);

  if (-d $src) {
    if ($self->_create_dir($file, $dest)) {
      $self->_log( level => "debug", message => "creating $file\n" );
      mkdir $path;
      chmod 0700, $path;
    }
    return failure "directory $path not found" unless (_catdir($path));
    return success;
  } elsif (-r $src) {
    if ($self->_create_dir($file, $dest)) {
      $self->_log( level => "debug", message => "copying $file\n" );

      # TODO - options to copy permissions

      copy($src, $path)
	|| return failure $self->_log( "copying failed: $!" );
      chmod 0600, $path;
    }
    return failure "file $path not found" unless (_catfile($path));
    return success;
  } else {
    return failure $self->_log( "cannot find file $src" );
  }
}

=item close_backup

  $plugin->close_backup();

Closes the backup.

=cut

sub close_backup {
  my $self = shift;
  my $path = $self->{path};
  $self->_log( level => "debug", message => "closing archive\n" );
  $self->{status} = "closed";
  return success;
}


=item close_restore

  $plugin->close_restore();

Closes the restore.

=cut

sub close_restore {
  my $self = shift;
  $self->_log( level => "debug", message => "closing archive\n" );
  $self->{status} = "closed";
  return success;
}


=begin internal

=item _log

  $moz->_log( $message, $level );

  $moz->_log( $message => $message, level => $level );

Logs an event to the dispatcher. If C<$level> is unspecified, "error"
is assumed.

=end internal

=cut

sub _log {
  my $self = shift;
  my %args = Params(qw( message ?level="error" ))->args(@_);
  my $msg  = $args{message};

  # we want log messages to always have a newline, but not necessarily
  # the returned value that we pass to carp/croak/return value

  $args{message} .= "\n" unless ($args{message} =~ /\n$/);
  $self->{log}->log(%args) if ($self->{log});
  return $msg;    # when used by carp/croak/return value
}

=begin internal

=item _catdir

=item _catfile

=end internal

=cut

sub _catdir {
  goto \&Mozilla::ProfilesIni::_catdir;
}

sub _catfile {
  goto \&Mozilla::ProfilesIni::_catfile;
}

1;

=back

=head1 EXAMPLES

=head2 Creating archvies other than zip or tar.gz

If you would like to create backups in a format for which no plugin
is available, you can use Mozilla::Backup::Plugin::FileCopy with a
system call to the appropriate archiver. For example,

  $moz = Mozilla::backup->new(
    plugin => "Mozilla::Backup::Plugin::FileCopy",
  );

  $dest = $moz->backup_profile(
    type => "firefox",
    name => "default",
  );

  system("tar cf - $dest |bzip2 - > firefox-default-profile.tar.bz2");

=head1 AUTHOR

Robert Rothenberg

=head1 LICENSE

Copyright (c) 2005 Robert Rothenberg. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut