Improving version history.

We already had support for read.

lib/GEmeTool/DB/Migrations.pm

@@ -23,6 +23,13 @@ sub MIGRATIONS {
             backup_input_file TEXT,
             backup_output_file TEXT
         );',
+        'CREATE TABLE backups_pk3 (
+            uuid TEXT PRIMARY KEY,
+            date datetime NOT NULL,
+            nickname TEXT,
+            pokemon_name TEXT,
+            file TEXT
+        );',
     );
 }
 1;

lib/GEmeTool/Log.pm

@@ -29,6 +29,7 @@ sub msg {
     my $msg         = shift;
     my $input_file  = shift;
     my $output_file = shift;
+    my $backup_pk3_file = shift;
     my ( $input_file_backup, $output_file_backup ) =
       $self->backup_files( $input_file, $output_file );
     my $db     = GEmeTool::DB->connect;
@@ -74,6 +75,8 @@ sub backup_files {
             next;
         }
         my $basename    = $file->basename;
+        $basename =~ s/\.\.//g;
+        $basename =~ s/\///g;
         my $output_file = $backup_dir->child("$digest-$basename");
         $output_file->spew_raw($contents);
         push @result_files, $output_file;

lib/GEmeTool/Save/Pokemon.pm

@@ -5,12 +5,20 @@ use v5.16.3;
 use strict;
 use warnings;
 
+use Data::Dumper;
+
 use Moo;
 use Rsaves;
 use Rsaves::Constants::Emerald::Species;
 use Rsaves::Constants::Emerald::SpeciesData;
+use Path::Tiny;
+use GEmeTool::DB;
+use GEmeTool::Config;
+use Digest::SHA   qw/sha256_hex/;
+use Digest::SHA qw/sha256_hex/;
+use UUID::URandom qw/create_uuid_string/;
 
-has _pokemon => ( is => 'rw', );
+has _pokemon => ( is => 'rw', required => 1 );
 
 sub species {
     my $self        = shift;
@@ -23,9 +31,41 @@ sub species {
     return $substruct_0->{species};
 }
 
+sub load_from_file {
+    my $class = shift;
+    my $file  = shift;
+    $file = path($file);
+    die 'No such plain file' if !-f $file;
+    return $class->new( _pokemon => Rsaves::read_pk3_file($file) );
+}
+
+sub export_file {
+    my $self = shift;
+    my $file = shift;
+    Rsaves::write_pk3_file( $self->_pokemon, $file );
+}
+
+sub export_raw {
+    my $self        = shift;
+    return Rsaves::get_pk3_raw($self->_pokemon);
+}
+
+sub empty {
+    my $class = shift;
+    return $class->new( _pokemon => Rsaves::read_pk3_raw( "\0" x 0x80 ) );
+}
+
+sub copy {
+    my $self                = shift;
+    my $object_to_copy_from = shift;
+    %{ $self->_pokemon } = %{ $object_to_copy_from->_pokemon };
+    return $self;
+}
+
 sub ivs {
     my $self = shift;
     my $arg  = shift;
+    print Data::Dumper::Dumper $self->_pokemon;
     my $current_value =
       $self->_pokemon->{substructures}[3]{ivs_egg_status_and_ability};
     my @stats = (
@@ -73,27 +113,27 @@ sub ivs {
 }
 
 sub evs {
-    my $self    = shift;
+    my $self         = shift;
-    my $arg  = shift;
+    my $arg          = shift;
-    my $pokemon = $self->_pokemon;
+    my $pokemon      = $self->_pokemon;
     my $substructure = $pokemon->{substructures}[2];
-    if (defined $arg) {
+    if ( defined $arg ) {
-        if (defined $arg->{HP}) {
+        if ( defined $arg->{HP} ) {
             $substructure->{hp_ev} = $arg->{HP};
         }
-        if (defined $arg->{Attack}) {
+        if ( defined $arg->{Attack} ) {
             $substructure->{attack_ev} = $arg->{Attack};
         }
-        if (defined $arg->{Defense}) {
+        if ( defined $arg->{Defense} ) {
             $substructure->{defense_ev} = $arg->{Defense};
         }
-        if (defined $arg->{Speed}) {
+        if ( defined $arg->{Speed} ) {
             $substructure->{speed_ev} = $arg->{Speed};
         }
-        if (defined $arg->{SpecialAttack}) {
+        if ( defined $arg->{SpecialAttack} ) {
             $substructure->{special_attack_ev} = $arg->{SpecialAttack};
         }
-        if (defined $arg->{SpecialDefense}) {
+        if ( defined $arg->{SpecialDefense} ) {
             $substructure->{special_defense_ev} = $arg->{SpecialDefense};
         }
     }
@@ -108,9 +148,10 @@ sub evs {
 }
 
 sub level {
-    my $self = shift;
+    my $self    = shift;
-    my $arg  = shift;
+    my $arg     = shift;
-    my $pokemon     = $self->_pokemon;
+    my $pokemon = $self->_pokemon;
+    return 0 if $self->species == 0;
     my $growth_func = sub {
         my $n = shift;
         if ( $n == 1 ) {
@@ -121,8 +162,8 @@ sub level {
     if ( defined $arg ) {
         $pokemon->{substructures}[0]{experience} = $growth_func->($arg);
     }
-    my $experience  = $pokemon->{substructures}[0]{experience};
+    my $experience = $pokemon->{substructures}[0]{experience};
-    my $level = 1;
+    my $level      = 1;
     while ( $level <= 100 && int( $growth_func->($level) ) <= $experience ) {
         $level++;
     }
@@ -356,4 +397,40 @@ sub get_front {
     }
     return "pokeemerald/graphics/pokemon/@{[lc($pokemon_name)]}/front.png";
 }
+
+sub backup {
+    my $self       = shift;
+    my $db         = GEmeTool::DB->connect;
+    my $data_dir   = GEmeTool::Config->new->data_dir;
+    my $backup_dir = $data_dir->child('backups/pk3');
+    $backup_dir->mkpath;
+    my $nickname = Rsaves::translate_3rd_encoding( $self->nickname );
+    $nickname =~ s/\.\.//g;
+    $nickname =~ s/\///g;
+    my $contents = $self->export_raw;
+    my $digest   = sha256_hex($contents);
+    my $file     = $backup_dir->child(
+        $nickname . '-' . $self->pokemon_name . '-' . $digest . '.pk3' )
+      ->absolute;
+    $file->spew_raw($contents);
+    my $uuid               = create_uuid_string();
+    my $query_check_exists = <<'EOF';
+SELECT file FROM backups_pk3
+WHERE file = ?
+EOF
+
+    if ( $db->selectrow_hashref( $query_check_exists, undef, $file ) ) {
+        $db->do( <<'EOF', undef, $file );
+UPDATE backups_pk3
+SET date=datetime('now')
+WHERE file = ?;
+EOF
+        return;
+    }
+    my $query = <<'EOF';
+INSERT INTO backups_pk3 (uuid, date, nickname, pokemon_name, file)
+VALUES (?, datetime('now'), ?, ?, ?);
+EOF
+    $db->do( $query, {}, $uuid, $self->nickname, $self->pokemon_name, $file );
+}
 1;

lib/GEmeTool/View/PokemonEditorWindow.pm

@@ -15,6 +15,9 @@ use Path::Tiny;
 use Rsaves;
 use Rsaves::Constants::Emerald::Species;
 use Rsaves::Constants::Emerald::Natures;
+use GEmeTool::Save::Pokemon;
+use GEmeTool::Options;
+use GEmeTool::DB;
 
 Glib::Object::Introspection->setup(
     basename => 'Gtk',
@@ -96,77 +99,227 @@ sub draw {
         }
     );
     $grid->attach( $canvas, 0, 0, 2, 2 );
-    my @species     = (@Rsaves::Constants::Emerald::Species::SPECIES);
+    my @species        = (@Rsaves::Constants::Emerald::Species::SPECIES);
-    my $string_list = Gtk4::StringList->new( [@species] );
+    my $string_list    = Gtk4::StringList->new( [@species] );
-    my $save_button = Gtk4::Button->new_with_label('Save changes');
+    my $restore_button = Gtk4::Button->new_with_label('Restore from backup');
+    my $save_button    = Gtk4::Button->new_with_label('Save changes');
+    my $delete_button  = Gtk4::Button->new_with_label('Delete pokemon');
+    my $import_button  = Gtk4::Button->new_with_label('Import .pk3');
+    my $export_button  = Gtk4::Button->new_with_label('Export .pk3');
     $self->_selected_species( $pokemon->species );
     my $box_right_image = Gtk4::Box->new( 'vertical', 1 );
     $box_right_image->set_margin_top(30);
     $box_right_image->set_valign('start');
     $box_right_image->set_halign('start');
-    my $box_ev = Gtk4::Box->new('vertical', 1);
+    my $box_ev = Gtk4::Box->new( 'vertical', 1 );
     $grid->attach( $box_right_image, 2, 0, 2, 2 );
-    $grid->attach( $box_ev, 4, 0, 2, 2 );
+    $grid->attach( $box_ev,          4, 0, 2, 2 );
-    $box_ev->append(Gtk4::Label->new('Select EV'));
+    $box_ev->append( Gtk4::Label->new('Select EV') );
     $self->create_select_level($box_ev);
     $self->create_select_evs($box_ev);
     $self->create_change_nickname_entry($box_right_image);
     $save_button->signal_connect(
         clicked => sub {
-            $pokemon->species( $self->_selected_species );
+            $self->activate_save;
-            $pokemon->personality( $self->_current_personality );
+        }
-            $self->recalculate_ivs;
+    );
-            $self->recalculate_evs;
+    $delete_button->signal_connect(
-            for my $func ( @{ $self->_save_callbacks } ) {
+        clicked => sub {
-                $func->();
+            $self->delete;
-            }
+        }
-            $self->draw;
+    );
+    $import_button->signal_connect(
+        clicked => sub {
+            $self->activate_import_pk3;
+        }
+    );
+    $export_button->signal_connect(
+        clicked => sub {
+            $self->activate_export_pk3;
+        }
+    );
+    $restore_button->signal_connect(
+        clicked => sub {
+            $self->activate_restore;
         }
     );
     $self->draw_dropdown_pokemon_list($box_right_image);
-    $box_right_image->append(Gtk4::Label->new('Select IV'));
+    my $box_label_iv = Gtk4::Box->new( 'horizontal', 10 );
+    $box_label_iv->append( Gtk4::Label->new('Select IV') );
+    $box_right_image->append($box_label_iv);
     $self->create_select_ivs($box_right_image);
     $self->create_modify_personality($grid);
-    $grid->attach( $save_button, 4, 7, 1, 1 );
+    $grid->attach( $save_button,    4, 7, 1, 1 );
+    $grid->attach( $export_button,  3, 7, 1, 1 );
+    $grid->attach( $delete_button,  2, 7, 1, 1 );
+    $grid->attach( $import_button,  1, 7, 1, 1 );
+    $grid->attach( $restore_button, 0, 7, 1, 1 );
     $window->set_child($grid);
 }
 
-sub create_select_level {
+sub activate_restore {
     my $self   = shift;
-    my $box = shift;
+    my $window = Gtk4::Window->new;
+    $window->set_title('Restore from backup');
+    my $scroll  = Gtk4::ScrolledWindow->new;
+    my $grid    = Gtk4::Grid->new;
+    my $backups = $self->get_backups;
+    my $i       = 0;
+    for my $backup (@$backups) {
+        my $nickname = Rsaves::translate_3rd_encoding( $backup->{nickname} );
+        my $pokemon_name = $backup->{pokemon_name};
+        my $file         = $backup->{file};
+        my $button =
+          Gtk4::Button->new_with_label( $nickname . '-' . $pokemon_name );
+        $button->signal_connect(
+            clicked => sub {
+                $self->activate_save;
+                $self->pokemon->backup;
+                $self->pokemon->copy(
+                    GEmeTool::Save::Pokemon->load_from_file($file) );
+                $self->draw;
+                $window->close;
+            }
+        );
+        $grid->attach( $button, $i % 6, int( $i / 6 ), 1, 1 );
+        $i++;
+    }
+    $window->set_child($grid);
+    $window->present;
+}
+
+sub get_backups {
+    my $self  = shift;
+    my $db    = GEmeTool::DB->connect;
+    my $query = <<'EOF';
+SELECT nickname, pokemon_name, file
+FROM backups_pk3
+ORDER BY date DESC;
+EOF
+    my $result = $db->selectall_arrayref( $query, { Slice => {} } );
+    return $result;
+}
+
+sub activate_save {
+    my $self    = shift;
     my $pokemon = $self->pokemon;
-    my $box_level = Gtk4::Box->new('horizontal', 10);
+    $pokemon->backup;
-    $box_level->append(Gtk4::Label->new('Lvl:'));
+    $pokemon->species( $self->_selected_species );
+    $pokemon->personality( $self->_current_personality );
+    $self->recalculate_ivs;
+    $self->recalculate_evs;
+    for my $func ( @{ $self->_save_callbacks } ) {
+        $func->();
+    }
+    $pokemon->backup;
+    $self->draw;
+}
+
+sub activate_export_pk3 {
+    my $self     = shift;
+    my $win      = $self->_win;
+    my $dialog   = Gtk4::FileDialog->new;
+    my $options  = GEmeTool::Options->new;
+    my $last_dir = $options->get_last_dir_open;
+    if ( defined $last_dir && -d $last_dir ) {
+        my $curdir = Glib::IO::File::new_for_path($last_dir);
+        $dialog->set_initial_folder($curdir);
+        $dialog->set_initial_name(
+                Rsaves::translate_3rd_encoding( $self->pokemon->nickname ) . '-'
+              . $self->pokemon->pokemon_name
+              . '.pk3' );
+    }
+    $dialog->save(
+        $win, undef,
+        sub {
+            my ( $self_dialog, $res ) = @_;
+            if ( $res->had_error ) {
+                return;
+            }
+            my $file = $dialog->save_finish($res);
+            return if !defined $file;
+            $file = path( $file->get_path );
+            $self->pokemon->export_file($file);
+        }
+    );
+}
+
+sub delete {
+    my $self = shift;
+    $self->pokemon->backup;
+    $self->pokemon->copy( GEmeTool::Save::Pokemon->empty );
+    $self->draw;
+}
+
+sub activate_import_pk3 {
+    my $self        = shift;
+    my $cancellable = Glib::IO::Cancellable->new;
+    my $dialog      = Gtk4::FileDialog->new;
+    my $win         = $self->_win;
+    my $options     = GEmeTool::Options->new;
+    my $last_dir    = $options->get_last_dir_open;
+    if ( defined $last_dir && -d $last_dir ) {
+        my $curdir = Glib::IO::File::new_for_path($last_dir);
+        $dialog->set_initial_folder($curdir);
+    }
+    $dialog->open(
+        $win,
+        $cancellable,
+        sub {
+            my ( $self_dialog, $res ) = @_;
+            if ( $res->had_error ) {
+                return;
+            }
+            my $file = $dialog->open_finish($res);
+            return if !defined $file;
+            $file = path( $file->get_path );
+            $options->set_last_dir_open( $file->parent . '' );
+            $self->activate_save;
+            $self->pokemon->copy(
+                GEmeTool::Save::Pokemon->load_from_file($file) );
+            $self->draw;
+        }
+    );
+}
+
+sub create_select_level {
+    my $self      = shift;
+    my $box       = shift;
+    my $pokemon   = $self->pokemon;
+    my $box_level = Gtk4::Box->new( 'horizontal', 10 );
+    $box_level->append( Gtk4::Label->new('Lvl:') );
     my $entry = Gtk4::Entry->new;
     $entry->set_input_purpose('digits');
-    $entry->get_buffer->set_text($pokemon->level, length $pokemon->level);
+    $entry->get_buffer->set_text( $pokemon->level, length $pokemon->level );
     $box_level->append($entry);
-    $self->onSave( sub {
+    $self->onSave(
-        my $text = $entry->get_buffer->get_text;
+        sub {
-        if ($text !~ /^[0-9]+$/) {
+            my $text = $entry->get_buffer->get_text;
-            return;
+            if ( $text !~ /^[0-9]+$/ ) {
+                return;
+            }
+            if ( $text > 100 ) {
+                $text = 100;
+            }
+            if ( $text < 2 ) {
+                $text = 2;
+            }
+            $pokemon->level($text);
         }
-        if ($text > 100) {
+    );
-            $text = 100;
-        }
-        if ($text < 2) {
-            $text = 2;
-        }
-        $pokemon->level($text);
-    });
     $box->append($box_level);
 }
 
 sub recalculate_evs {
-    my $self   = shift;
+    my $self    = shift;
     my $pokemon = $self->pokemon;
-    for my $key ( @stats ) {
+    for my $key (@stats) {
         my $text = $self->_ev_buffers->{$key}->get_text;
         next if $text !~ /^[0-9]+$/;
-        if ($text > 255) {
+        if ( $text > 255 ) {
             $text = 255;
         }
-        if ($text < 0) {
+        if ( $text < 0 ) {
             $text = 0;
         }
         $pokemon->evs(
@@ -178,15 +331,15 @@ sub recalculate_evs {
 }
 
 sub recalculate_ivs {
-    my $self   = shift;
+    my $self    = shift;
     my $pokemon = $self->pokemon;
-    for my $key ( @stats ) {
+    for my $key (@stats) {
         my $text = $self->_iv_buffers->{$key}->get_text;
         next if $text !~ /^[0-9]+$/;
-        if ($text > 31) {
+        if ( $text > 31 ) {
             $text = 31;
         }
-        if ($text < 0) {
+        if ( $text < 0 ) {
             $text = 0;
         }
         $pokemon->ivs(

lib/Rsaves.pm

@@ -29,7 +29,7 @@ our @EXPORT_OK = (
     qw/read_pc_storage save_pc_changes save_changes enable_eon_ticket
       add_key_item set_flag_id change_gender read_save get_saves
       find_current_save_index check_correct_size find_pokemon_substruct
-      read_pkm_file_box calculate_shiny_personality pokemon_set_shiny
+      calculate_shiny_personality pokemon_set_shiny
       get_first_super_data set_first_super_data enable_rematch_main_legendary
       check_flag_id enable_mirage_island_for_pokemon parse_version_name
       enable_deoxys_firered match_again_rival_firered_cerulean pokemon_fill_pp to_3rd_encoding translate_3rd_encoding check_rematch/
@@ -144,11 +144,11 @@ sub calculate_shiny_personality {
 
 sub pokemon_is_shiny {
     my $pokemon = shift;
-    return is_shiny(@{$pokemon}{ 'otid', 'personality' });
+    return is_shiny( @{$pokemon}{ 'otid', 'personality' } );
 }
 
 sub is_shiny {
-    my $otid = shift;
+    my $otid        = shift;
     my $personality = shift;
     return ( _lowhalf_u32($personality) ^ _hihalf_u32($personality)
           ^ _lowhalf_u32($otid) ^ _hihalf_u32($otid) ) < 8;
@@ -264,7 +264,7 @@ sub _read_pokemon_boxes_from_fh {
         for my $j ( 0 .. 29 ) {
             read $fh, my $pokemon_data, 0x50 or die "Failed to read 0x50 bytes";
             open my $pokemon_fh, '<', \$pokemon_data;
-            push @$box, _read_pokemon_box_from_fh($pokemon_fh);
+            push @$box, _read_pokemon_from_fh($pokemon_fh);
             close $pokemon_fh;
         }
         push @$boxes, $box;
@@ -272,18 +272,41 @@ sub _read_pokemon_boxes_from_fh {
     return $boxes;
 }
 
-sub read_pkm_file_box {
+sub read_pk3_file {
     my $file = shift;
     open my $fh, '<', $file or die "Unable to open $file";
     my $file_contents = join '', <$fh>;
-    $file_contents = substr $file_contents, 0, 0x50;
+    return read_pk3_raw($file_contents);
-    open $fh, '<', \$file_contents;
+}
-    return _read_pokemon_box_from_fh( $fh, 1 );
+
+sub read_pk3_raw {
+    my $raw = shift;
+    $raw = substr $raw, 0, 0x50;
+    open my $fh, '<', \$raw;
+    return _read_pokemon_from_fh( $fh, 1 );
+}
+
+sub get_pk3_raw {
+    my $pokemon = shift;
+    my $return  = '';
+    open my $fh, '>', \$return;
+    _write_pokemon_fh( $fh, $pokemon, 1 );
+    close $fh;
+    return $return;
+}
+
+sub write_pk3_file {
+    my $pokemon = shift;
+    my $file = shift;
+    my $content = get_pk3_raw($pokemon);
+    open my $fh, '>', $file or return;
+    print $fh $content;
 }
 
 sub _write_pokemon_fh {
-    my $fh      = shift;
+    my $fh          = shift;
-    my $pokemon = shift;
+    my $pokemon     = shift;
+    my $is_pkm_file = shift;
     if ( $pokemon->{personality} > 0xFFFFFFFF ) {
         die "Too big personality";
     }
@@ -307,8 +330,10 @@ sub _write_pokemon_fh {
     {
         open my $fh_substructures, '>', \$substructures_raw;
         $pokemon->{checksum} = _write_pokemon_substructures_fh(
-            $fh_substructures,       $pokemon->{substructures},
+            $fh_substructures,
-            $pokemon->{personality}, $pokemon->{otid}
+            $pokemon->{substructures},
+            $pokemon->{personality},
+            $pokemon->{otid}, $is_pkm_file, 
         );
         close $fh_substructures;
     }
@@ -320,7 +345,7 @@ sub _write_pokemon_fh {
     print $fh $substructures_raw;
 }
 
-sub _read_pokemon_box_from_fh {
+sub _read_pokemon_from_fh {
     my $fh          = shift;
     my $is_pkm_file = shift;
 
@@ -406,10 +431,14 @@ sub _write_pokemon_substructures_fh {
     my $substructures           = shift;
     my $personality             = shift;
     my $otid                    = shift;
+    my $is_pkm_file             = shift;
     my $modulo                  = $personality % 24;
     my $decrypted_substructures = '';
     open my $fh_decrypted_substructures, '>', \$decrypted_substructures;
-    my @order_substructures = _pokemon_substructures_order_by_modulo($modulo);
+    my @order_substructures =
+      ( $is_pkm_file
+        ? ( 0 .. 3 )
+        : _pokemon_substructures_order_by_modulo($modulo) );
 
     my $substruct0 = find_pokemon_substruct( $substructures, 0 );
 
@@ -430,14 +459,20 @@ sub _write_pokemon_substructures_fh {
     seek $fh_decrypted_substructures, 0, 0;
     my $encrypted_substructures;
     open my $fh_encrypted_substructures, '>', \$encrypted_substructures;
-    for ( 0 .. 11 ) {
+    if (!$is_pkm_file) {
-        read $fh_decrypted_substructures, my $read, 4;
+        for ( 0 .. 11 ) {
-        $read = pack 'V', ( ( ( unpack 'V', $read ) ^ $personality ) ^ $otid );
+            read $fh_decrypted_substructures, my $read, 4;
-        print $fh_encrypted_substructures $read;
+            $read = pack 'V', ( ( ( unpack 'V', $read ) ^ $personality ) ^ $otid );
+            print $fh_encrypted_substructures $read;
+        }
     }
     close $fh_decrypted_substructures;
     close $fh_encrypted_substructures;
-    print $fh $encrypted_substructures;
+    if ($is_pkm_file) {
+        print $fh $decrypted_substructures;
+    } else {
+        print $fh $encrypted_substructures;
+    }
     return $checksum;
 }