perl/lib/Thrasher/Backend/Migrate.pm

   1 package Thrasher::Backend::Migrate;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base 'Exporter';
   7
   8 our @EXPORT_OK = qw(migrate migrate_from_spec);
   9
  10 use Data::Dumper;
  11 use Thrasher;
  12
  13 sub migrate_from_spec {
  14     my $source_backend = shift;
  15     my $source_backend_specs = shift;
  16     my $dest_backend = shift;
  17     my $dest_backend_specs = shift;
  18     my @args = @_;
  19
  20
  21     $source_backend = "Thrasher::Backend::$source_backend";
  22     $dest_backend = "Thrasher::Backend::$dest_backend";
  23
  24     {
  25         local $@;
  26         eval "use $source_backend;";
  27         die if $@;
  28
  29         eval "use $dest_backend;";
  30         die if $@;
  31     }
  32
  33     my $source = $source_backend->new($source_backend_specs);
  34     my $dest = $dest_backend->new($dest_backend_specs);
  35
  36     migrate($source, $dest, @args);
  37 }
  38
  39 sub migrate {
  40     my $source = shift;
  41     my $dest = shift;
  42     my %args = @_;
  43
  44     my $dry_run = $args{dry_run};
  45
  46     print "Preparing to migrate backend data...\n";
  47
  48     if (! $args{'protocol_module'}) {
  49         die('No protocol_module to register; cannot get registration_items!');
  50     }
  51     eval("require $args{'protocol_module'};")
  52       or die $@;
  53     my $protocol = $args{'protocol_module'}->new({}, $dest);
  54     $dest->register_protocol($protocol);
  55
  56     my $source_jids = $source->all_jids;
  57
  58     for my $jid (@$source_jids) {
  59         print "Migrating $jid... ";
  60         local $@;
  61         eval {
  62             # Migrate registration
  63             my $registration = $source->registered($jid);
  64             if ($registration) {
  65                 if ($dry_run) {
  66                     print "Would register $jid with: "
  67                         . Dumper($registration);
  68                 } else {
  69                     $dest->register($jid, $registration);
  70                 }
  71             }
  72
  73             # Migrate the mappings
  74             my $mappings = $source->all_mappings($jid);
  75             if ($dry_run) {
  76                 print "Got mappings to migrate: " . Dumper($mappings);
  77             } else {
  78                 while (my ($legacy, $mapped_jid) = each %$mappings) {
  79                     # The source transport may have a different
  80                     # canonical form for public IM usernames. This may
  81                     # cause Thrasher to think $legacy was not already
  82                     # mapped and create a duplicate mapping (e.g.
  83                     # optional spaces for AIM).
  84                     $legacy = $protocol->process_remote_username($legacy);
  85
  86                     $dest->store_username_mapping($jid, $legacy, $mapped_jid);
  87                 }
  88             }
  89
  90             # Migrate roster
  91             my $roster = $source->get_roster($jid);
  92             if ($dry_run) {
  93                 print "Got roster to migrate: " . Dumper($roster);
  94             } else {
  95                 $dest->set_roster($jid, $roster);
  96             }
  97
  98             # Migrate misc, if any
  99             {
 100                 local $@;
 101                 eval {
 102                     my $all_misc = $source->all_misc($jid);
 103                     if ($dry_run) {
 104                         print "Got misc to migrate: "
 105                             . Dumper($all_misc);
 106                     } else {
 107                         while (my ($key, $value) = each %$all_misc) {
 108                             $dest->set_misc($jid, $key, $value);
 109                         }
 110                     }
 111                 };
 112                 # "If this errored for some reason other than
 113                 # one end or the other not supporting misc,
 114                 # propogate the error, otherwise eat it."
 115                 if ($@ && $@ !~ /not implemented/) {
 116                     die;
 117                 }
 118             }
 119
 120             # Migrate the avatars.
 121             my $avatars = $source->all_avatars($jid);
 122             if ($dry_run) {
 123                 print "Got avatars to migrate: " . Dumper(sort keys
 124                                                           %$avatars);
 125             } else {
 126                 while (my ($legacy, $avatar) = each %$avatars) {
 127                     $dest->set_avatar($jid, $legacy, $avatar);
 128                 }
 129             }
 130         };
 131
 132         if ($@) {
 133             warn "While trying to migrate $jid, got error: $@";
 134         } else {
 135             print "done.\n";
 136         }
 137     }
 138 }
 139
 140 1;