Mozilla::Backup - Backup utility for Mozilla profiles

  $moz = Mozilla::Backup->new();
  $file = $moz->backup_profile("firefox", "default");

  $moz->method($type,$name);

  $moz->type($type)->method($name);

package Mozilla::Backup;

use 5.006;
use strict;
use warnings;

use Carp;
# use Config::IniFiles;
use File::Copy qw( copy );
use File::Find;
use File::Spec;
use IO::File;
use Log::Dispatch 1.6;
use Module::Pluggable;
use Mozilla::ProfilesIni;
use Params::Smart 0.04;
use Regexp::Assemble;
use Regexp::Common 1.8 qw( comment balanced delimited );
use Return::Value;

# $Revision: 1.64 $

our $VERSION = '0.06';

# Note: the 'pseudo' profile type is deliberately left out.
#       'minotaur' is obsolete, and so omitted; what about 'phoenix'?

# TODO: add support for Epiphany, SkipStone, and DocZilla, if relevant

my @PROFILE_TYPES = qw(
  beonex camino firefox galeon k-meleon mozilla netscape phoenix
  sunbird thunderbird
);

sub profile_types {
  return @PROFILE_TYPES;
}

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

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

sub _find_all_profiles {
  my $self = shift;

  my $home = $ENV{HOME};
  if ($^O eq "MSWin32") {
    $home  = $ENV{APPDATA} ||
      _catdir($ENV{USERPROFILE}, "Application Data") ||
      _catdir($ENV{WINDIR}, "Profiles", "Application Data") ||
      _catdir($ENV{WINDIR}, "Application Data");

    # Question: is WinDir set for all Windows 9x/WinNT machines? Where
    # is the code that Mozilla uses to determine where the profile
    # should be?

  }

  foreach my $type (profile_types) {
    if (my $path = Mozilla::ProfilesIni::_find_profile_path(
                     home => $home, type => $type)) {
      if (_catfile($path, "profiles.ini")) {
	$self->{profiles}->{$type} =
	  Mozilla::ProfilesIni->new( path => $path, debug => $self->{debug} );
      }
    } else {
    }
  }
  if ($self->{pseudo}) {
    my $pseudo = 
      Mozilla::ProfilesIni->new( path => $self->{pseudo}, create => 1,
				 debug => $self->{debug} );
    $pseudo->create_profile( name => "default", is_default => 1 ),
      unless ($pseudo->profile_exists( name => "default" ));
    $self->{profiles}->{pseudo} = $pseudo;
  }
}

sub _load_plugin {
  my $self   = shift;
  my %args = Params(qw( plugin *?options ))->args(@_);
  my $plugin = $args{plugin};
  my $opts   = $args{options} || { };

  local ($_);

  # TODO - check if plugin already loaded

  eval "CORE::require $plugin";
  if ($@) {
    croak $self->_log( "Unable to load plugin plugin" );
  }
  else {
    # We check to see if the plugin supports the methods we
    # need. Would it make more sense to have a base class and test
    # isa() instead?

    foreach (qw(
      allowed_options new munge_location open_for_backup open_for_restore
      get_contents backup_file restore_file close_backup close_restore
    )) {
      croak $self->_log( "Plugin does not support $_ method" )
      unless ($plugin->can($_));
    }

    # We check to see if the plugin accepts certain options

    my %copts = ( );
    foreach (qw( log debug )) {
      $copts{$_} = $self->{$_} if ($plugin->allowed_options($_));
    }
    $self->{plugin} = $plugin->new(%copts,%$opts);
  }
  return $self->{plugin};
}

sub new {
  my $class = shift || __PACKAGE__;

  my %args  = Params(
   {
     name     => "plugin",
     default  => "Mozilla::Backup::Plugin::Zip",
     callback => sub {
       my ($self, $name, $value) = @_;
       croak "expected scalar or array reference"

	 unless ((!ref $value) || (ref($value) eq "ARRAY"));
       return $value;
     },
     name_only => 0,
   },
   {
     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,
   },
   {
     name      => "pseudo",
     default   => "",
     callback  => sub {
       my ($self, $name, $value) = @_;
       $value ||= "";
       croak "invalid pseudo directory"
	 unless (($value eq "") || _catdir($value));
       return $value;
     },
     name_only => 1,
   },
   {
     name      => "debug",
     default   => 0,
     name_only => 1,
   },
   {
     name     => "exclude",
     default  => [
       '^Cache(.Trash)?\/',                # web cache
       'XUL\.(mfl|mfasl)',                 # XUL cache
       'XUL FastLoad File',                # XUL cache 
       '(Invalid|Aborted)\.mfasl',         # Invalidated XUL
       'panacea.dat',                      # mail folder cache
       '(\.parentlock|parent\.lock|lock)', # lock file
     ],
     callback => sub {
       my ($self, $name, $value) = @_;
       $value = [ $value ] unless (ref $value);
       croak "expected scalar or array reference"
	 unless (ref($value) eq "ARRAY");
       local ($_);
       foreach (@$value) {
	 croak "expected regular expression"
	   unless ((!ref $value) || (ref($value) eq "Regexp"));	 
       }
       return $value;
     },
     name_only => 0,
     slurp     => 1,
   },
  )->args(@_);
		     
  my $self  = {
    profiles  => { },
  };

  local ($_);

  foreach (qw( log debug pseudo exclude )) {
    $self->{$_} = $args{$_};
  }

  bless $self, $class;

  if ($self->{debug}) {
    require Log::Dispatch::Screen;
    $self->{log}->add( Log::Dispatch::Screen->new(
      name      => __PACKAGE__,
      min_level => "debug",
      stderr    => 1,
    ));
  }

  {
    my $plugin = $args{plugin};
    my $opts   = [ ];
    if (ref($plugin) eq 'ARRAY') {
      $opts   = $plugin;
      $plugin = shift @{$opts};
    }
    $self->_load_plugin( plugin => $plugin, options => { @$opts } );
  }
  $self->_find_all_profiles();

  return $self;
}

sub found_profile_types {
  my $self = shift;
  return (keys %{$self->{profiles}});
}

sub type {
  my $self = shift;
  my %args = Params(qw( type ))->args(@_);
  my $type = $args{type};
  return $self->{profiles}->{$type} ||
    croak $self->_log(
      "invalid profile type: $type"
    );
}

sub type_exists {
  my $self = shift;
  my %args = Params(qw( type ))->args(@_);
  my $type = $args{type};
  return (exists $self->{profiles}->{$type});
}

sub _backup_path {
  my $self = shift;
  my %args = Params(qw( profile_path destination relative ))->args(@_);
  my $path     = $args{profile_path};
  my $dest     = $args{destination};
  my $relative = $args{relative};

  # TODO - an option for overwriting existing files?

  if (-e $dest) {
    return failure
      $self->_log( "$dest exists already" );
  }

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

  unless ($self->{plugin}->open_for_backup( path => $dest)) {
    return failure
      $self->_log( "error creating archive" );
  }


  my $exclude = Regexp::Assemble->new( debug => $self->{debug} );
  $exclude->add( @{$self->{exclude}} );

  find({
	bydepth    => 1,
	wanted     => sub {
	  my $file = $File::Find::name;
	  my $name = $relative ? substr($file, length($path)) : $file;
	  if ($name) {
	    $name = substr($name,1); # remove initial '/'

	    unless ($name =~ $exclude->re) {
	      $name .= '/' if (-d $file);
              my $r = $self->{plugin}->backup_file($file, $name);
		return failure $self->_log(
		  "error backing up $file: $r" ) unless ($r);
	    }
	  }

	},
       }, $path
      );

  # TODO: check for errors here
  unless ($self->{plugin}->close_backup()) {
    return failure "close_backup failed";
  }

  return success;
}

sub backup_profile {
  my $self = shift;
  my %args = Params(qw( type name ?destination ?archive_name ?relative ))
    ->args(@_);
  my $type = $args{type};
  my $name = $args{name};

  my $prof = $self->type( type => $type );

  my $dest = $args{destination}  || '.';
  my $arch = $args{archive_name} ||
    $self->_archive_name( type => $type, name => $name);

  # TODO - if destination includes a file name, use it. The plugin
  # should have methods for parsing destination appropriate to the
  # backup method.

  my $back = File::Spec->catfile($dest, $arch);

  # This needs to be rethought here. IsRelative refers to the Path in
  # the .ini file being relative, but does it also refer to locations
  # from within the profile being stored relatively? Not sure here.

  my $relative = $args{relative};

  $relative = $prof->profile_is_relative( name => $name )
    unless (defined $relative);

  unless ($relative) {
    $self->_log( level => "notice",
      message => "backup will not use relative pathnames\n" );
  }

  if ($prof->profile_is_locked( name => $name )) {
    return failure $self->_log( 
      "cannot backup locked profile" );
  }

  my $r = $self->_backup_path(
    profile_path => $prof->profile_path( name => $name ),
    destination  => $back,
    relative     => $relative
  );
  return failure $r unless ($r);

  return $back;
}

sub _archive_name {
  my $self = shift;
  my %args = Params(qw( type name ))->args(@_);
  my $type = $args{type};
  my $name = $args{name};

  # We don't really care about validating profile types and names
  # here. If it's invalid, so what. We just have a name that doesn't
  # refer to any actual profiles.

  my $timestamp   = sprintf("%04d%02d%02d-%02d%02d%02d",
       (localtime)[5]+1900, (localtime)[4]+1,
       reverse((localtime)[0..3]),
  );
  my $arch = join("-", $type, $name, $timestamp);
  return $self->{plugin}->munge_location($arch);
}

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
}

# TODO - test if we really need this. Thunderbird saves the relative
# path info, which we use for munging. But we need to check the
# behavior, since in the case where we copy profiles, we don't want it
# using a valid path but for a different profile.

sub _munge_prefs_js {
  my $self = shift;
  my %args = Params(qw( profile_path ?prefs_file ))->args(@_);
  my $profd    = $args{profile_path};
  my $filename = $args{prefs_file} || _catfile($profd, "prefs.js");

  unless (-d $profd) {
    return failure $self->_log( "Invalid profile path: $profd" );
  }

  unless (-r $filename) {
    return failure $self->_log( "Invalid prefs file: $filename" );
  }

  my $fh = IO::File->new("<$filename")
    || return failure $self->_log( "Unable to open file: $filename" );

  my $buffer = join("", <$fh>);

  close $fh ||
    return failure $self->_log( "Unable to close file: $filename" );

  $buffer =~ s/$RE{comment}{Perl}//g;
  $buffer =~ s/$RE{comment}{JavaScript}//g;

  my %prefs = ( );

  local ($_);
  foreach (split /\n/, $buffer) {
    if ($_ =~ /user_pref($RE{balanced}{-parens=>'()'})\;/) {
      my $args = $1;
      if ($args =~ /\(\s*($RE{delimited}{-delim=>'"'}{-esc})\,\s*(.+)\s*\)/) {
	my ($pref, $val) = ($1, $2);
        $pref = substr($pref,1,-1);
        $prefs{$pref} = $val;
#	print "user_pref(\"$pref\", $val);\n";
      }
      else {
	return failure $self->_log( "Don\'t know how to handle line: $args" );
      }
      
    }
  }

  my $re = Regexp::Assemble->new();
  $re->add(
    qr/^mail\.root\.pop3$/,
    qr/^mail\.server\.server\d+\.(directory|newsrc\.file)$/,
  );

  foreach my $pref (keys %prefs) {
    if ($pref =~ $re->re) {
      if (exists $prefs{$pref."-rel"}) {
	if ($prefs{$pref."-rel"} =~ /\"\[ProfD\](.+)\"/) {
	  my $path = File::Spec->catdir($profd, $1);
          $path =~ s/\\{2,}/\\/g; # unescape multiple slashes
          unless (-e $path) {
            $self->_log( level => "warn",
              message => "Path does not exist: $path", );
          }
          $path =~ s/\\/\\\\/g;   # escape single slashes
          $prefs{$pref} = "\"$path\"";
        }
        else {
          $self->_log( level => "warn",
           message => "Cannot handle $pref-rel key", );
        }
      }
      else {
          $self->_log( level => "warn",
           message => "Cannot find $pref-rel key", );
      }
    }
    elsif ($pref =~ /\.dir$/) {
      # TODO - check if directory exists, and if not, give a warning
    }
  }

  if (keys %prefs) {
    copy($filename, $filename.".backup");
    chmod 0600, $filename.".backup";

    $fh = IO::File->new(">$filename")
      || return failure $self->_log ( "Unable to write to $filename" );

    print $fh "
# Mozilla User Preferences

/* Do not edit this file. 
  * 
  * This file was modified by Mozilla::Backup.
  *
  * The original is at $filename.backup
  */

";

    foreach my $pref (sort keys %prefs) {
      print $fh "user_pref(\"$pref\", $prefs{$pref});\n";
    }

    close $fh || return failure $self->_log( "Unable to close $filename" );
  } else {
    return failure $self->_log( "No preferences to save" );
  }

  return success;
}

sub restore_profile {
  my $self = shift;
  my %args =
    Params(qw( archive_path type name ?is_default ?+munge_prefs ))->args(@_);
  my $path = $args{archive_path};
  my $type = $args{type};
  my $name = $args{name};
  my $def  = $args{is_default} || 0;
  my $munge = $args{munge_prefs} || 0;

  my $prof = $self->type( type => $type );

  unless ($prof->profile_exists( name => $name)) {
    $self->_log( level => "info",
       message => "creating new profile: $name\n" );

    unless ($prof->create_profile(
      name       => $name,
      is_default => $def )) {
      return failure $self->_log( "unable to create profile: $name" );
    }
  }
  unless ($prof->profile_exists( name => $name )) {
    return failure $self->_log(
      "unable to create profile: $name"
    );
  }

  my $dest = $prof->profile_path( name => $name );
  unless (-d $dest) {
    return failure $self->_log( "invalid profile path$ path" );
  }

  if ($prof->profile_is_locked( name => $name )) {
    return failure $self->_log( "cannot restore locked profile" );
  }

  # Note: the guts of this should be moved to a _restore_profile method

  my $exclude = Regexp::Assemble->new( debug => $self->{debug} );
  $exclude->add( @{$self->{exclude}} );

  if ($self->{plugin}->open_for_restore($path)) {
    foreach my $file ($self->{plugin}->get_contents) {
      # TODO:
      # - an option for overwriting existing files?
      # - handle relative profile issues!

      unless ($file =~ $exclude->re) {
	unless ($self->{plugin}->restore_file($file, $dest)) {
	  return failure $self->_log( "unable to restore files $file" );
	}
      }
    }
    $self->{plugin}->close_restore;

    if ($munge) {
      if (my $filename = _catfile($dest, "prefs.js")) {
	my $r = $self->_munge_prefs_js(
	  profile_path => $dest,
	  prefs_file   => $filename,
	);
        return failure $r unless ($r);
      } else {
	$self->_log( level => "warn", message => "Cannot find prefs.js" );
      }
    }

  }
  else {
    return failure $self->_log( "unable to open backup: $path" );
  }

  return success;
}

# TODO - a separate copy_profile method that copies a profile into another
#        one for the same application

our $AUTOLOAD;

sub AUTOLOAD {
  my $self  = shift;
  $AUTOLOAD =~ /.*::(\w+)/;
  my $meth  = $1;
  if (Mozilla::ProfilesIni->can($meth)) {
    carp $self->_log(
      level => "warn",
      message => "Warning: deprecated method \"$meth\"",
    );
    if ($_[0] eq "type") {
      my %args = @_;
      my $type = $args{type}; delete $args{type};
      return $self->type(type => $type)->$meth(%args);
    }
    else {
      my @args = @_;
      my $type = shift @args;
      return $self->type(type => $type)->$meth(@args);
    }
  }
  else {
    croak $self->_log( 
      "Unrecognized object method \"$meth\" in \"".__PACKAGE__."\"",
    );
  }
}

# Otherwise AUTOLOAD looks for a DESTROY method

sub DESTROY {
  my $self = shift;
  undef $self;
}

1;