#!/usr/bin/perl use warnings; use strict; #================================================================================= # Daggerfall Launcher #================================================================================= # # This launcher should work, but I cannot guarantee that, # it was written on Arch Linux and not tried anywhere else # if you want to use it on other system, adjust configuration # below and keep your fingers crossed! # # Run it with "--help" option to get help. # # Remember that you use it at your own risk :-) #================================================================================= # License #================================================================================= # Copyright (C) 2011 by Andrzej Giniewicz # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to deal # in the Software without restriction, including without limitation the rights # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell # copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN # THE SOFTWARE. #================================================================================= # Configuration variables #================================================================================= my $user_group = 'games'; my $daggerfall_path = "/usr/share/games/daggerfall"; my $license = "/usr/share/licenses/daggerfall/license"; my $dosbox = "/usr/bin/dosbox"; my $dosbox_config = "dagger.conf"; my $daggerfall_dir = "DAGGER"; my $palettes_dir = "palettes"; my $license_lock = "terms-accepted"; my $save_backup_dir = "save-backups"; my $archive_type = ".tar.xz"; my $archiver_pack = "tar -cJf 'ARCHIVE' *"; my $archiver_unpack = "tar -xJf 'ARCHIVE'"; my $mods_dir = "mods"; my $mod_backup_dir = "modbackup"; #================================================================================= # Declarations and description of available functions #================================================================================= # check if terms of use were accepted # no arguments # returns boolean sub terms_accepted; # get terms of use # no arguments # returns array of lines sub get_terms; # accept terms of use # no arguments # no return value sub accept_terms; # run Daggerfall, requires that terms of use are already accepted # no arguments # no return value sub run_daggerfall; # run sound setup utility # no arguments # no return value sub run_setup; # run save fixing utility # no arguments # no return value sub run_fixsave; # run map fixing utility # no arguments # no return value sub run_fixmaps; # get brightness increase in steps # (0 steps = no change; 1 step = multiply gamma by 1.1, 2 steps = multiply gamma by 1.2, etc) # no arguments # returns number sub get_brightness; # set brightness increase in steps # (0 steps = no change; 1 step = multiply gamma by 1.1, 2 steps = multiply gamma by 1.2, etc) # takes number of steps # no return value sub set_brightness; # get wagon capacity in lbs # no arguments # returns number sub get_wagon_capacity; # set wagon capacity in lbs # takes number representing wagon capacity # no return value sub set_wagon_capacity; # check if skill levels above 100 are unlocked # no arguments # returns boolean sub get_high_skills; # enable or disable skill levels above 100 # takes boolean, 0 to disable, 1 to enable # no return value sub set_high_skills; # get view distance in save stored in given slot # takes save slot number (0 to 5) # returns view distance (0 to 255) sub get_view_distance; # set view distance in save stored in given slot # (in-game this cannot be set higher than 127) # takes save slot number (0 to 5) and view distance (0 to 255) # no return value sub set_view_distance; # check if cheat mode is enabled # no arguments # returns boolean sub get_cheat_mode; # enable or disable cheat mode # takes boolean, 0 to disable, 1 to enable # no return value sub set_cheat_mode; # check if magic item repairs are enabled # no arguments # returns boolean sub get_magic_repair; # enable or disable magic item repairs # takes boolean, 0 to disable, 1 to enable # no return value sub set_magic_repair; # get current save names # no arguments # returns hash from slot numbers (0-5) to save names (strings) sub get_current_saves; # get archived save names # no arguments # returns hash from slot numbers (0-5) to hashes from names (strings) to array # of dates (YYYY_MM_DD_HH_MM_SS) when saves were archived sub get_archived_saves; # archive current save from given slot # takes slot number (0-5) # no return value sub archive_save; # check if there is save in given slot # takes slot number (0-5) # returns boolean, 1 for occupied slot, 0 otherwise sub is_slot_occupied; # restore selected save into given slot # (possible specifications: # (slot numer) -> same as (slot number)-(game name), where (game name) is # name of game currently in given slot # (slot number)-(game name) -> same as (slot number)-(game name)-(date), # where (date) is date of last archived save from given slot with given name # (slot number)-(game name)-(date) -> full specification, unpacks save named # (game name) archived from slot (slot number) on (date) # takes archived save specification (string) and target slot (0-5) # no return value sub restore_save; # get list of installed mods # no arguments # returns array of installed mod names sub get_mods; # get list of enabled mods # no arguments # returns array of enabled mod names sub get_enabled_mods; # get list of available mod groups # no arguments # returns array of available mod group names sub get_mod_groups; # get list of mod or group dependencies # no arguments # returns array of mod and group names sub get_direct_mod_dependencies; # get list of mod or group dependencies (recursively) # no arguments # returns array of mod names sub get_all_mod_dependencies; # get list of enabled mods requiring given mod # takes string (mod name) # returns array of mod names sub get_mods_requiring; # enable mod # takes string (name of mod or group to enable) # no return value sub enable_mod; # disable mod # takes string (name of mod to disable) # no return value sub disable_mod; # refresh all installed mods to currently installed versions # no arguments # no return value sub refresh_mods; #================================================================================= # Gory details :-) #================================================================================= use File::Copy qw(copy move); use File::Find qw(find); use File::Path qw(remove_tree); use File::Spec::Functions qw(catfile); use List::Util qw(min max); my $gid = getgrnam($user_group); sub terms_accepted { return ( -e catfile($daggerfall_path, $license_lock) ); } sub accept_terms { my $file = catfile($daggerfall_path, $license_lock); open(FILE, ">$file") or die "Cannot create license lock"; close(FILE); chmod 0664, $file; chown -1, $gid, $file; } sub get_terms { open(FILE, "<$license") or die "Cannot open license"; my @text = ; close(FILE); return @text; } sub fix_dirs; sub fix_dirs { my $path = shift; chmod 0775, $path; chown -1, $gid, $path; opendir(DIR, $path) or die "Cannot access target directory"; my @files = readdir(DIR); closedir(DIR); @files = grep(!/\./, @files); foreach my $file (@files) { my $full = catfile($path, $file); if ( -d $full) { fix_dirs $full; } else { chmod 0664, $full; chown -1, $gid, $full; } } } sub run_dosbox { my ($app, $exit, $no_terms) = @_; $no_terms or terms_accepted or die "Terms of usage not accepted"; my $run = catfile($daggerfall_path, $daggerfall_dir, $app); ( -e $run) or die "Cannot find requested application"; my $cfg = catfile($daggerfall_path, $dosbox_config); ( -e $cfg) or die "Cannot find dosbox config file"; if ($exit) { system($dosbox." ".$run." -exit -conf ".$cfg); } else { system($dosbox." ".$run." -conf ".$cfg); } fix_dirs catfile($daggerfall_path, $daggerfall_dir); } sub run_daggerfall { run_dosbox "RUN.BAT", 1, 0; } sub run_setup { run_dosbox "SETUP.EXE", 1, 1; } sub run_fixsave { run_dosbox "FIXSAVE.EXE", 0, 1; } sub run_fixmaps { run_dosbox "FIXMAPS.EXE", 0, 1; } sub get_brightness { my $pal = catfile($daggerfall_path, $palettes_dir); ( -d $pal ) or return 0; my $file = catfile($pal, "now"); ( -e $file) or return 0; open(FILE, "<$file") or die "Cannot open brighness record"; binmode(FILE); my $buffer=""; read(FILE, $buffer, 8); close(FILE); return unpack("d", $buffer); } sub set_brightness { my $steps = shift; my $gamma = 1+$steps/10; my %palettes = ( 'ARENA2' => [ "MAP.PAL", "ART_PAL.COL", "DANKBMAP.COL", "FMAP_PAL.COL", "NIGHTSKY.COL", "OLDMAP.PAL", "OLDPAL.PAL", "PAL.PAL", "PAL.RAW" ], 'DATA' => [ "DAGGER.COL" ] ); sub edit_palette { my ($source_file, $gamma) = @_; my $palette_size = -s $source_file; my $source; my $target = ""; open(FILE, "<$source_file") or die "cannot open $source_file"; binmode(FILE); if ($palette_size == 768) { read(FILE, $source, 768); } elsif ($palette_size == 776) { read(FILE, $target, 8); read(FILE, $source, 768); } else { close(FILE); die "$source_file is unknown palette format\n"; } close(FILE); $target eq "\x08\x03\x00\x00\x23\xb1\x00\x00" || $target eq "" || die "$source_file is unknown palette format\n"; sub transform { my ($c, $g) = @_; return max(0,min(int(255*(0.385/($g-0.5)+0.23)*($c/255)**(1/$g)+0.5),255)); } my @source_data = unpack("C*", $source); my @target_data; foreach my $byte (@source_data) { push(@target_data, (transform $byte, $gamma)); } $target = $target . pack("C*", @target_data); open(FILE, ">$source_file") or die "cannot write $source_file"; binmode(FILE); print FILE $target; close(FILE); } (-d catfile($daggerfall_path, $daggerfall_dir)) or die "Cannot find Daggerfall directory"; my $source_dir = catfile($daggerfall_path, $palettes_dir); if ( ! -d $source_dir ) { mkdir $source_dir or die "Cannot create palettes directory"; chmod 0775, $source_dir; chown -1, $gid, $source_dir; } foreach my $dir (keys %palettes) { my $target_dir = catfile($daggerfall_path, $daggerfall_dir, $dir); foreach my $palette (@{$palettes{$dir}}) { if ( ! -e catfile($source_dir, $palette) ) { copy( catfile($target_dir, $palette), catfile($source_dir, $palette) ) or die "Cannot copy palette file"; chmod 0664, catfile($source_dir, $palette); chown -1, $gid, catfile($source_dir, $palette); } copy( catfile($source_dir, $palette), catfile($target_dir, $palette) ) or die "Cannot copy palette file"; chmod 0664, catfile($target_dir, $palette); chown -1, $gid, catfile($target_dir, $palette); edit_palette(catfile($target_dir, $palette), $gamma); } } my $file = catfile($source_dir, "now"); open(FILE, ">$file") or die "Cannot save brighness record"; binmode(FILE); print FILE pack("d", $steps); close(FILE); } sub get_wagon_capacity { my $fall = catfile($daggerfall_path, $daggerfall_dir, "FALL.EXE"); ( -e $fall ) or die "Cannot find FALL.EXE"; ( -s $fall == 1864183 ) or die "Wrong FALL.EXE length"; open(FILE, "<$fall") or die "cannot open FALL.EXE"; binmode(FILE); seek(FILE, 917011, 0); my $buffer=""; read(FILE, $buffer, 2); close(FILE); my @bytes = unpack("C*", $buffer); return $bytes[0]/4+$bytes[1]*64; } sub set_wagon_capacity { my $val = shift; my $len = length $val; my $rep = int((5-$len)/2); my $out = " "x$rep . "/" . " "x$rep . $val; if (length $out == 5) { $out = $out." " }; my $high = int($val/64); my $low = 4*$val-256*$high; (length $out == 6) and ($low >= 0) and ($low <= 255) and ($high >= 0) and ($high <= 255) or die "Bad value $val."; my $bytes = pack("C*", ($low, $high)); my $fall = catfile($daggerfall_path, $daggerfall_dir, "FALL.EXE"); ( -e $fall ) or die "Cannot find FALL.EXE"; ( -s $fall == 1864183 ) or die "Wrong FALL.EXE length"; open(FILE, "<$fall") or die "cannot open FALL.EXE"; binmode(FILE); my $buffer; read(FILE, $buffer, 917011); $buffer = $buffer.$bytes; seek(FILE, 2, 1); read(FILE, $buffer,854164,917013); $buffer = $buffer.$out; seek(FILE, 6, 1); read(FILE, $buffer,93000,1771183); close(FILE); open(FILE, ">$fall") or die "cannot write FALL.EXE"; binmode(FILE); print FILE $buffer; close(FILE); } sub get_high_skills { my $fall = catfile($daggerfall_path, $daggerfall_dir, "FALL.EXE"); ( -e $fall ) or die "Cannot find FALL.EXE"; ( -s $fall == 1864183 ) or die "Wrong FALL.EXE length"; open(FILE, "<$fall") or die "cannot open FALL.EXE"; binmode(FILE); seek(FILE, 556836, 0); my $buffer=""; read(FILE, $buffer, 1); close(FILE); return ($buffer eq "\xc8"); } sub set_high_skills { my $enable = shift; my $fall = catfile($daggerfall_path, $daggerfall_dir, "FALL.EXE"); ( -e $fall ) or die "Cannot find FALL.EXE"; ( -s $fall == 1864183 ) or die "Wrong FALL.EXE length"; open(FILE, "<$fall") or die "cannot open FALL.EXE"; binmode(FILE); my $buffer; read(FILE, $buffer, 1864183); close(FILE); if ($enable) { substr($buffer, 556836, 2, "\xc8\x72"); substr($buffer, 558213, 2, "\xc8\x77"); substr($buffer, 558234, 2, "\xc8\x76"); substr($buffer, 558253, 1, "\xc8"); substr($buffer, 558320, 2, "\xc8\x76"); substr($buffer, 558342, 1, "\xc8"); substr($buffer, 558833, 1, "\xc8"); substr($buffer, 557953, 1, "\x7f"); } else { substr($buffer, 556836, 2, "\x64\x7c"); substr($buffer, 558213, 2, "\x64\x7f"); substr($buffer, 558234, 2, "\x64\x7e"); substr($buffer, 558253, 1, "\x64"); substr($buffer, 558320, 2, "\x64\x7e"); substr($buffer, 558342, 1, "\x64"); substr($buffer, 558833, 1, "\x64"); substr($buffer, 557953, 1, "\x64"); } open(FILE, ">$fall") or die "cannot write FALL.EXE"; binmode(FILE); print FILE $buffer; close(FILE); } sub find_distance { my $slot = shift; my $file = catfile($daggerfall_path,$daggerfall_dir,"SAVE".$slot,"SAVETREE.DAT"); open(FILE, "<$file") or die "cannot open save from slot $slot"; my $buffer; my $step; my $ans; binmode(FILE); seek(FILE, 19, 1); read(FILE, $buffer, 4); $step = unpack("L", $buffer); seek(FILE, $step, 1); read(FILE, $buffer, 4); $step = unpack("L", $buffer); while ($step > 0) { read(FILE, $buffer, 1); if (unpack("C", $buffer) == 23) { seek(FILE, 71, 1); $ans = tell FILE; close(FILE); return $ans; } else { seek(FILE, $step-1, 1); } read(FILE, $buffer, 4); $step = unpack("L", $buffer); } close(FILE); die "No settings record found"; } sub get_view_distance { my $slot = shift; my $place = find_distance $slot; my $file = catfile($daggerfall_path,$daggerfall_dir,"SAVE".$slot,"SAVETREE.DAT"); open(FILE, "<$file") or die "cannot open save from slot $slot"; binmode(FILE); seek(FILE, $place, 1); my $buffer; read(FILE, $buffer, 1); close(FILE); return unpack("C", $buffer); } sub set_view_distance { my ($slot, $value) = @_; my $place = find_distance $slot; ($value>0) && ($value < 266) || die "Wrong distance value"; my $file = catfile($daggerfall_path,$daggerfall_dir,"SAVE".$slot,"SAVETREE.DAT"); my $buffer; open(FILE, "<$file") or die "cannot open save from slot $slot"; binmode(FILE); read(FILE, $buffer, -s $file); close(FILE); substr($buffer, $place, 1, pack("C", $value)); open(FILE, ">$file") or die "cannot write save from slot $slot"; binmode(FILE); print FILE $buffer; close(FILE); } sub get_label { my $label = shift; $label =~ tr/[A-Z]/[a-z]/; my $file = catfile($daggerfall_path,$daggerfall_dir,"Z.CFG"); open(FILE, "<$file") or die "cannot open config file"; while () { my $line = $_; $line =~ tr/[A-Z]/[a-z]/; $line =~ s/\s+//g; if ($line =~ /^$label/) { close(FILE); return ($line =~ /1$/); } } close(FILE); return 0; } sub set_label { my ($label, $value) = @_; $label =~ tr/[A-Z]/[a-z]/; my $file = catfile($daggerfall_path,$daggerfall_dir,"Z.CFG"); open(FILE, "<$file") or die "cannot open config file"; my @lines = ; close(FILE); open(FILE, ">$file") or die "cannot write to config file"; my $found = 0; foreach my $line (@lines) { my $copy = $line; $copy =~ tr/[A-Z]/[a-z]/; $copy =~ s/\s+//g; if ($copy =~ /^$label/) { $found = 1; print FILE $label." ".$value."\r\n"; } else { print FILE $line; } } if (! $found) { print FILE $label." ".$value."\r\n"; } close(FILE); } sub get_cheat_mode { return get_label "cheatmode"; } sub set_cheat_mode { my $val = shift; if ($val) { set_label "cheatmode", 1; } else { set_label "cheatmode", 0; } } sub get_magic_repair { return get_label "magicrepair"; } sub set_magic_repair { my $val = shift; if ($val) { set_label "magicrepair", 1; } else { set_label "magicrepair", 0; } } sub is_slot_occupied { my $slot = shift; return ( -e catfile($daggerfall_path,$daggerfall_dir,"SAVE".$slot,"SAVENAME.TXT")) } sub get_save_name { my $slot = shift; ( is_slot_occupied $slot ) or die "Slot empty"; my $file = catfile($daggerfall_path,$daggerfall_dir,"SAVE".$slot,"SAVENAME.TXT"); my $name = ""; open(FILE, "<$file") or die "Cannot open save file"; binmode(FILE); read(FILE,$name,32); $name =~ s/\x00.*//; return $name } sub get_current_saves { my %saves = (); foreach my $slot (0..5) { if (is_slot_occupied $slot) { $saves{$slot} = get_save_name $slot } } return %saves; } sub get_archived_saves { my %saves = (); my $dir = catfile($daggerfall_path, $save_backup_dir); ( -d $dir) or return %saves; opendir(DIR, $dir) or die "Cannot access save backup directory"; my @files = readdir(DIR); closedir(DIR); foreach my $file (@files) { if ( $file !~ /^\./) { $file =~ s/$archive_type$//; my @struct = split /-/, $file; my $slot = $struct[0]; my $date = $struct[-1]; my $name = join('-',@struct[1..($#struct-1)]); if ( ! exists $saves{$slot} ) { $saves{$slot} = {}; } if ( ! exists $saves{$slot}{$name} ) { $saves{$slot}{$name} = []; } push($saves{$slot}{$name}, $date); } } return %saves; } sub archive_save { my $slot = shift; my $dir = catfile($daggerfall_path, $save_backup_dir); if ( ! -d $dir) { mkdir $dir or die "Cannot create save backup directory"; chmod 0775, $dir; chown -1, $gid, $dir; } my $save_path = catfile($daggerfall_path,$daggerfall_dir,"SAVE".$slot); my $file = catfile($save_path,"SAVENAME.TXT"); ( -e $file ) or die "No save in slot $slot"; my $name; open(FILE, "<$file") or die "Cannot open save file"; binmode(FILE); read(FILE,$name,32); $name =~ s/\x00.*//g; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time); my $date = sprintf("%4d_%02d_%02d_%02d_%02d_%02d", ($year+1900), ($mon+1), $mday, $hour, $min, $sec); my $archive = catfile($daggerfall_path, $save_backup_dir, $slot."-".$name."-".$date.$archive_type); my $call = $archiver_pack; $call =~ s/ARCHIVE/$archive/; chdir($save_path); system($call); chmod 0664, $archive; chown -1, $gid, $archive; } sub expand_save_name { my $which = shift; if ($which =~ /^[0-5]$/) { my $file = catfile($daggerfall_path,$daggerfall_dir,"SAVE".$which, "SAVENAME.TXT"); ( -e $file) or return ""; my $name; open(FILE, "<$file") or return ""; binmode(FILE); read(FILE,$name,32); $name =~ s/\x00.*//g; $which = $which."-".$name; } if ($which !~ /[0-9][0-9][0-9][0-9]_[0-9][0-9]_[0-9][0-9]_[0-9][0-9]_[0-9][0-9]_[0-9][0-9]$/) { my $dir = catfile($daggerfall_path, $save_backup_dir); opendir(DIR, $dir) or return ""; my @files = readdir(DIR); closedir(DIR); @files = sort grep(/^$which/, @files); ($#files > 0) or return ""; my $last = $files[-1]; $last =~ s/$archive_type$//; $last =~ s/^$which//; $which = $which.$last; } ( -e catfile($daggerfall_path, $save_backup_dir, $which.$archive_type) ) or return ""; return $which } sub restore_save { my ($which, $where) = @_; my $target = catfile($daggerfall_path,$daggerfall_dir,"SAVE".$where); ( -d $target) or die "No save directory for slot $where"; $which = expand_save_name $which; $which or die "No stored save meets requirements"; $which = $which.$archive_type; my $source = catfile($daggerfall_path, $save_backup_dir, $which); my $call = $archiver_unpack; $call =~ s/ARCHIVE/$source/; opendir(DIR, $target) or die "Cannot access target directory"; my @files = readdir(DIR); closedir(DIR); ( $#files == 1) or remove_tree($target, {keep_root => 1} ) or die "Cannot cleanup target directory"; chdir($target) or die "Cannot access target directory"; system($call); fix_dirs $target; } sub is_mod { my $mod = shift; return ( -d catfile($daggerfall_path, $mods_dir, $mod) ); } sub has_patch { my $mod = shift; ( is_mod $mod) or return 0; return ( -e catfile($daggerfall_path, $mods_dir, $mod.".patch") ); } sub was_mod { my $mod = shift; ( ! is_mod $mod) or return 0; return ( -e catfile($daggerfall_path, $mods_dir, $mod.".enabled") ); } sub is_group { my $mod = shift; return (( -e catfile($daggerfall_path, $mods_dir, $mod.".extends")) and ( ! -d catfile($daggerfall_path, $mods_dir, $mod))) } sub is_mod_enabled; sub is_mod_enabled { my $mod = shift; if (is_mod $mod) { return ( -e catfile($daggerfall_path, $mods_dir, $mod.".enabled")) } elsif (was_mod $mod) { return 1 } elsif (is_group $mod) { my $file = catfile($daggerfall_path, $mods_dir, $mod.".extends"); open(FILE, "<$file") or die "Cannot access mods group"; my @mods = ; close(FILE); foreach my $file (@mods) { $file =~ s/\r|\n//g; (is_mod_enabled $file) or return 0; } return 1; } else { die "Value $mod does not point to mod or group" } } sub get_mods { my @mods = (); my $dir = catfile($daggerfall_path, $mods_dir); ( -d $dir ) or return @mods; opendir(DIR, $dir) or die "Cannot access mods directory"; my @files = readdir(DIR); closedir(DIR); @files = grep(!/^\./,@files); @files = grep(!/\.enabled$/,@files); @files = grep(!/\.patch$/,@files); @mods = grep(!/\.extends$/,@files); return sort @mods; } sub get_enabled_mods { my @mods = (); my $dir = catfile($daggerfall_path, $mods_dir); ( -d $dir ) or return @mods; opendir(DIR, $dir) or die "Cannot access mods directory"; my @files = readdir(DIR); closedir(DIR); @files = grep(/enabled$/,@files); foreach my $mod (@files) { $mod =~ s/.enabled$//; if (( is_mod $mod ) or (was_mod $mod)) { push(@mods, $mod) } } return sort @mods; } sub get_mod_groups { my @mods = get_mods; my @groups = (); my $dir = catfile($daggerfall_path, $mods_dir); ( -d $dir ) or return @mods; opendir(DIR, $dir) or die "Cannot access mods directory"; my @files = readdir(DIR); closedir(DIR); foreach my $modex (grep(/\.extends$/,@files)) { my $mod = $modex; $mod =~ s/.extends$//; my @temp = grep(/^$mod$/,@mods); if ($#temp) { push(@groups, $mod) } } return sort @groups; } sub get_mod_dependencies; sub get_mod_dependencies { my ($mod, $rec) = @_; my @deps = (); if (was_mod $mod) { my $dir = catfile($daggerfall_path, $mod_backup_dir); find sub { my $file = $File::Find::name; ( ! -d $file) or return; ($file =~ /$mod$/) or return; $file =~ s/^$dir.//; ($file !~ /^FALL\.EXE/) or return; my $temp = $file; $file =~ s/-[0-9]*-$mod$//; $temp =~ s/.*-([0-9]*)-$mod$/$1/; $temp or return; $temp = $temp - 1; find sub { my $test = $File::Find::name; ( ! -d $test) or return; $test =~ s/^$dir.//; ($test =~ /^$file-$temp/) or return; ($test !~ /orig$/) or return; $test =~ s/^$file-$temp-//; my @temp = grep(/^$test$/, @deps); if ($#temp==-1) { push(@deps, $test); } ( $rec ) or return; my @recdeps = get_mod_dependencies $test, $rec; foreach my $file (@recdeps) { my @temp = grep(/^$file$/, @deps); if ($#temp==-1) { push(@deps, $file); } } }, $dir; }, $dir; return sort @deps; } (is_mod $mod) or (is_group $mod) or die "Value $mod does not point to mod or group"; my $file = catfile($daggerfall_path, $mods_dir, $mod.".extends"); ( -e $file ) or return @deps; open(FILE, "<$file") or die "Cannot access mods group"; my @mods = ; close(FILE); foreach my $file (@mods) { $file =~ s/\r|\n//g; my @temp = grep(/^$file$/, @deps); if ($#temp==-1) { push(@deps, $file); } if ( ($rec) and (-e catfile($daggerfall_path, $mods_dir, $file.".extends") )) { my @recdeps = get_mod_dependencies $file, $rec; foreach my $file (@recdeps) { my @temp = grep(/^$file$/, @deps); if ($#temp==-1) { push(@deps, $file); } } } } return sort @deps; } sub get_direct_mod_dependencies { my $mod = shift; return get_mod_dependencies $mod, 0; } sub get_all_mod_dependencies { my $mod = shift; return get_mod_dependencies $mod, 1; } sub get_mods_requiring { my $mod = shift; (is_mod $mod) or (was_mod $mod) or die "Value $mod does not represent mod"; my @mods = get_enabled_mods; my @result = (); foreach my $name (@mods) { my @deps = get_all_mod_dependencies $name; my @temp = grep(/^$mod$/, @deps); if ($#temp != -1) { my @temp = grep(/^$name$/, @result); if ($#temp == -1) { push(@result, $name); } } } return @result; } sub is_mod_conflicting { my $mod = shift; ( is_mod $mod ) or die "$mod is not a mod"; ( ! is_mod_enabled $mod ) or return 0; my @possible_conflicts = (); my $dir = catfile($daggerfall_path, $mod_backup_dir); ( -d $dir ) or return @possible_conflicts; my $moddir = catfile($daggerfall_path, $mods_dir, $mod); find sub { my $file = $File::Find::name; ( ! -d $file ) or return; $file =~ s/^$moddir.//; my @file_conflicts = (); find sub { my $backup = $File::Find::name; ( ! -d $backup) or return; $backup =~ s/^$dir.//; if ($backup =~ /^$file/) { $backup =~ s/^$_-//; ($backup !~ /0-orig/) or return; my @parts = split(/-/, $backup); $backup = join('-',@parts); my $slot = $parts[0]; while (! (is_mod($backup) or was_mod($backup))) { $slot = $parts[0]; shift @parts; $backup = join('-',@parts); } ($backup ne $mod) or return; my @temp = grep(/^$slot-backup$/,@file_conflicts); if ($#temp==-1) { push(@file_conflicts,"$slot-$backup"); } } }, $dir; (@file_conflicts) or return; my $conflict = (sort @file_conflicts)[-1]; my @temp = split(/-/,$conflict); shift @temp; $conflict = join('-',@temp); @temp = grep(/^$conflict$/,@possible_conflicts); if ($#temp == -1) { push(@possible_conflicts, $conflict); } }, $moddir; my @conflicts = (); my @deps = get_direct_mod_dependencies $mod; foreach my $conflict (@possible_conflicts) { my @temp = grep(/^$conflict$/, @deps); if ($#temp == -1) { push(@conflicts, $conflict); } } return sort @conflicts; } sub get_file_in_mods_count { my $file = shift; my $dir = catfile($daggerfall_path, $mod_backup_dir); ( -d $dir ) or return 0; my @backups = (); find sub { my $backup = $File::Find::name; $backup =~ s/^$dir.//; ( $backup eq $dir ) or push(@backups, $backup); }, $dir; @backups = grep(/^$file/, @backups); return (1+$#backups); } sub rm { my $file = shift; ( -e $file ) or return; ( ! -d $file ) or return; unlink @{[$file]} or die "Cannot delete file"; } sub dir_empty { my $dir = shift; ( -d $dir ) or return 0; opendir(DIR, $dir); my @files = readdir(DIR); closedir(DIR); return ($#files == 1); } sub enable_patch { my $mod = shift; my $file = catfile($daggerfall_path, $mods_dir, $mod.".patch"); open(FILE, "<$file") or die "Cannot open patch file"; my @lines = ; close(FILE); $file = catfile($daggerfall_path, $mod_backup_dir, "FALL.EXE-$mod"); open(FILE, ">$file") or die "Cannot create FALL.EXE backup"; my $fall = catfile($daggerfall_path, $daggerfall_dir, "FALL.EXE"); open(FALL, "<$fall") or die "Cannot open FALL.EXE file"; binmode(FALL); my $buffer; read(FALL, $buffer, 1864183); foreach my $part (@lines) { $part =~ s/\r|\n//g; my @data = split(/\ /, $part); my $offset = $data[0]; shift @data; my $length = $data[0]; shift @data; my $out = pack("C*", @data); seek FALL, $offset, 0; my $buf; read FALL, $buf, $length; my @orig = unpack("C*", $buf); my $origval = join(" ", @orig); print FILE "$offset $length $origval\n"; substr($buffer, $offset, $length, $out); } close(FILE); close(FALL); open(FALL, ">$fall") or die "Cannot open FALL.EXE file"; binmode(FALL); print FALL $buffer; close(FALL); } sub disable_patch { my $mod = shift; my $file = catfile($daggerfall_path, $mod_backup_dir, "FALL.EXE-$mod"); open(FILE, "<$file") or die "Cannot read FALL.EXE backup"; my @lines = ; close(FILE); my $fall = catfile($daggerfall_path, $daggerfall_dir, "FALL.EXE"); open(FALL, "<$fall") or die "Cannot open FALL.EXE file"; binmode(FALL); my $buffer; read(FALL, $buffer, 1864183); close(FALL); foreach my $part (@lines) { $part =~ s/\r|\n//g; my @data = split(/\ /, $part); my $offset = $data[0]; shift @data; my $length = $data[0]; shift @data; my $out = pack("C*", @data); substr($buffer, $offset, $length, $out); } open(FALL, ">$fall") or die "Cannot open FALL.EXE file"; binmode(FALL); print FALL $buffer; close(FALL); rm $file; } sub enable_mod { my $mod = shift; (is_mod $mod) or (is_group $mod) or die "Value $mod does not point to mod or group"; (! is_mod_enabled $mod) or return; my @deps = get_direct_mod_dependencies $mod; foreach my $dep (@deps) { (is_mod_enabled $dep) or enable_mod $dep; } ( is_mod $mod ) or return; my $dir = catfile($daggerfall_path, $mod_backup_dir); if ( ! -d $dir ) { mkdir $dir or die "Cannot create mod backup directory"; chmod 0775, $dir; chown -1, $gid, $dir; } my @conflicts = is_mod_conflicting $mod; ( ! @conflicts ) or die "Mod is conflicting with: ".join(' ', @conflicts); my $moddir = catfile($daggerfall_path, $mods_dir, $mod); find sub { my $source = $File::Find::name; my $file = $source; ($file ne $moddir) or return; $file =~ s/^$moddir.//; ( $file !~ /^FALL.EXE$/ ) or die "Bad mod, FALL.EXE can be modded only trough patches"; my $target = catfile($daggerfall_path, $daggerfall_dir, $file); my $backup = catfile($dir, $file); if ( -d $source ) { if ( ! -d $target ) { mkdir $target or die "Cannot create directory"; chmod 0775, $target; chown -1, $gid, $target; } if ( ! -d $backup ) { mkdir $backup or die "Cannot create directory"; chmod 0775, $backup; chown -1, $gid, $backup; } } else { if ( ! -e $target ) { copy($source, $target) or die "Cannot copy file"; chmod 0664, $target; chown -1, $gid, $target; open(FILE, ">$backup-0-$mod") or die "Cannot create file"; close(FILE); chmod 0664, "$backup-0-$mod"; chown -1, $gid, "$backup-0-$mod"; } else { my $id = get_file_in_mods_count $file; if ($id == 0) { open(FILE, ">$backup-0-orig") or die "Cannot create file"; close(FILE); chmod 0664, "$backup-0-orig"; chown -1, $gid, "$backup-0-orig"; $id = 1; } copy($target, "$backup-$id-$mod") or die "Cannot copy file"; chmod 0664, "$backup-$id-$mod"; chown -1, $gid, "$backup-$id-$mod"; copy($source, $target) or die "Cannot copy file"; chmod 0664, $target; chown -1, $gid, $target; } } }, $moddir; if ( has_patch $mod ) { enable_patch $mod; } open(FILE, ">$moddir.enabled") or die "Cannot create file"; close(FILE); chmod 0664, "$moddir.enabled"; chown -1, $gid, "$moddir.enabled"; } sub disable_mod { my $mod = shift; ( is_mod $mod ) or ( was_mod $mod) or die "Value $mod does not represent mod"; ( was_mod $mod ) or ( is_mod_enabled $mod ) or return; my @temp = get_mods_requiring $mod; my $count = $#temp+1; ( ! $count ) or die "There are $count mods requiring $mod, cannot disable"; my $dir = catfile($daggerfall_path, $mod_backup_dir); find sub { my $file = $File::Find::name; $file =~ s/^$dir.//; ($file ne $dir) or return; ($file =~ /$mod$/) or return; my $id = $file; $file =~ s/-[0-9]*-$mod$//; if ($file =~ /FALL.EXE/) { disable_patch $mod; } else { $id =~ s/^$file-//; $id =~ s/-$mod$//; my $source = catfile($dir, "$file-$id-$mod"); my $target = catfile($daggerfall_path, $daggerfall_dir, $file); if ($id == 0) { rm($source); rm($target); } else { move($source, $target) or die "Cannot restore backup"; chmod 0664, $target; chown -1, $gid, $target; if ($id == 1) { rm(catfile($dir, "$file-0-orig")); } } } }, $dir; my @to_remove = (); find { no_chdir => 1, wanted => sub { my $file = $File::Find::name; ($file ne $dir) or return; (-d $file) or return; (dir_empty $file) or return; push(@to_remove, $file); $file =~ s/^$dir.//; $file = catfile($daggerfall_path, $daggerfall_dir, $file); (dir_empty $file) or return; push(@to_remove, $file); }}, $dir; foreach my $file (@to_remove) { remove_tree($file) or die "Cannot remove leftover directory"; } rm(catfile($daggerfall_path, $mods_dir, "$mod.enabled")); } sub refresh_mods { my @mods = get_enabled_mods; my @enabled_mods = @mods; while ($#enabled_mods >= 0) { foreach my $mod (@enabled_mods) { my @temp = get_mods_requiring $mod; my $count = $#temp+1; if ( ! $count ) { disable_mod $mod; } } @enabled_mods = get_enabled_mods; } foreach my $mod (@mods) { if (is_mod $mod) { enable_mod $mod } } } #================================================================================= # Command line interface, options parsing #================================================================================= use Getopt::Long; my $opt_run_daggerfall=1; my $opt_force_run_daggerfall=0; my $opt_help=0; my $opt_accept_terms=0; my $opt_run_setup=0; my $opt_run_fixsave=0; my $opt_run_fixmaps=0; my $opt_get_brightness=0; my $opt_set_brightness=""; my $opt_get_wagon_capacity=0; my $opt_set_wagon_capacity=""; my $opt_get_high_skills=0; my $opt_set_high_skills=""; my $opt_get_view_distance=""; my %opt_set_view_distance=(); my $opt_get_cheat_mode=0; my $opt_set_cheat_mode=""; my $opt_get_magic_repair=0; my $opt_set_magic_repair=""; my $opt_list_saves=0; my $opt_list_archived_saves=0; my $opt_archive_save=""; my $opt_archive_all_saves=0; my %opt_restore_save=(); my $opt_list_mods=0; my $opt_enable_mod=""; my $opt_disable_mod=""; my $opt_refresh_mods=0; my $die_early=0; Getopt::Long::Configure('pass_through'); GetOptions ( 'help' => \$opt_help, 'accept-terms' => \$opt_accept_terms, 'run-daggerfall' => \$opt_force_run_daggerfall, 'run-setup' => \$opt_run_setup, 'run-fixsave' => \$opt_run_fixsave, 'run-fixmaps' => \$opt_run_fixmaps, 'get-brightness' => \$opt_get_brightness, 'set-brightness=f' => \$opt_set_brightness, 'get-wagon-capacity' => \$opt_get_wagon_capacity, 'set-wagon-capacity=i' => \$opt_set_wagon_capacity, 'get-high-skills' => \$opt_get_high_skills, 'set-high-skills=s' => \$opt_set_high_skills, 'get-view-distance=i' => \$opt_get_view_distance, 'set-view-distance=i' => \%opt_set_view_distance, 'get-cheat-mode' => \$opt_get_cheat_mode, 'set-cheat-mode=s' => \$opt_set_cheat_mode, 'get-magic-repair' => \$opt_get_magic_repair, 'set-magic-repair=s' => \$opt_set_magic_repair, 'list-saves' => \$opt_list_saves, 'list-archived-saves' => \$opt_list_archived_saves, 'archive-save=i' => \$opt_archive_save, 'archive-all-saves' => \$opt_archive_all_saves, 'restore-save=i' => \%opt_restore_save, 'list-mods' => \$opt_list_mods, 'enable-mod=s' => \$opt_enable_mod, 'disable-mod=s' => \$opt_disable_mod, 'refresh-mods' => \$opt_refresh_mods ); if ($opt_set_brightness ne "") { if ($opt_set_brightness < 0) { print "Bad value for --set-brightness ($opt_set_brightness)\n"; $opt_help = 1; } } if ($opt_set_wagon_capacity ne "") { if (($opt_set_wagon_capacity <= 0) or ($opt_set_wagon_capacity >= 16384)) { print "Bad value for --set-wagon-capacity ($opt_set_wagon_capacity)\n"; $opt_help = 1; } } if ($opt_set_high_skills ne "") { if ($opt_set_high_skills !~ /on|off/) { print "Bad value for --set-high-skills ($opt_set_high_skills)\n"; $opt_help = 1; } } if ($opt_get_view_distance ne "") { if (($opt_get_view_distance < 0) or ($opt_get_view_distance > 5)) { print "Bad value for --get-view-distance ($opt_get_view_distance)\n"; $opt_help = 1; } if ( ! is_slot_occupied $opt_get_view_distance ) { print "No save in slot $opt_get_view_distance\n"; $die_early = 1; } } foreach my $key (keys %opt_set_view_distance) { my $val = $opt_set_view_distance{$key}; if ($key !~ /[0-5]/) { print "Bad slot value for --set-view-distance ($key)\n"; $opt_help = 1; } if (($val < 0) or ($val > 255)) { print "Bad view distance value for --set-view-distance $key ($val)\n"; $opt_help = 1; } if ( ! is_slot_occupied $key ) { print "No save in slot $key\n"; $die_early = 1; } } if ($opt_set_cheat_mode ne "") { if ($opt_set_cheat_mode !~ /on|off/) { print "Bad value for --set-cheat-mode ($opt_set_cheat_mode)\n"; $opt_help = 1; } } if ($opt_set_magic_repair ne "") { if ($opt_set_magic_repair !~ /on|off/) { print "Bad value for --set-magic-repair ($opt_set_magic_repair)\n"; $opt_help = 1; } } if ($opt_archive_save ne "") { if (($opt_archive_save < 0) or ($opt_archive_save > 5)) { print "Bad value for --archive-save ($opt_archive_save)\n"; $opt_help = 1; } if ( ! is_slot_occupied $opt_archive_save ) { print "No save in slot $opt_archive_save\n"; $die_early = 1; } } my %conflict_vals = (); foreach my $key (keys %opt_restore_save) { my $val = $opt_restore_save{$key}; if ( (expand_save_name $key) eq "" ) { print "No save matching $key\n" } if (($val < 0) or ($val > 5)) { print "Bad slot targets for --restore-save $key ($val)\n"; $opt_help = 1; } if (exists $conflict_vals{$val}) { print "Conflicting slot targets\n"; $die_early = 1; } else { $conflict_vals{$val} = 1; } } if ($opt_enable_mod ne "") { if ((! is_mod $opt_enable_mod) and (! is_group $opt_enable_mod)) { print "Bad mod name for --enable-mod ($opt_enable_mod)\n"; $opt_help = 1; } elsif ((is_mod $opt_enable_mod) and (is_mod_enabled $opt_enable_mod)) { print "Mod \"$opt_enable_mod\" already enabled\n"; $die_early = 1; } elsif (is_mod $opt_enable_mod) { my @conflicts = is_mod_conflicting $opt_enable_mod; if (@conflicts) { print "Mod \"$opt_enable_mod\" is conflicting with: ".join(' ', @conflicts)."\n"; $die_early = 1; } } } if ($opt_disable_mod ne "") { if (! is_mod $opt_disable_mod) { print "Bad mod name for --disable-mod ($opt_disable_mod)\n"; $opt_help = 1; } elsif ( ! is_mod_enabled $opt_disable_mod) { print "Mod \"$opt_disable_mod\" not enabled\n"; $die_early = 1; } } if ($#ARGV >= 0) { foreach my $arg (@ARGV) { print "Unknown option: $arg\n"; } $opt_help = 1; } #================================================================================= # Command line interface, commands #================================================================================= if ($opt_help) { print " The Elder Scrolls II: Daggerfall launcher usage: daggerfall [options] available conflicting options: --run-setup run the sound setup utility --run-fixsave run fixsave, the save game fixing utility --run-fixmaps run fixmaps, the map fixing utility --run-daggerfall when any option is specified Daggerfall will not be started by launcher. This options forces start of game when all other tasks are finished --get-brightness returns current palette brightness 0 means original, 1 means multiply gamma by 1.1, 2 means multiply gamma by 1.2, etc. --set-brightness= sets brightness, accept any non-negative number (reasonable values are between 0 and 10) --get-wagon-capacity returns current wagon capacity (in lbs) --set-wagon-capacity= sets current wagon capacity, accepts values between 1 to 16384 --get-high-skills checks if skill levels above 100 are unlocked --set-high-skills= unlocks/locks skill levels above 100, accepts two values - on and off --get-cheat-mode checks if cheat mode is enabled --set-cheat-mode= enables/disables cheat mode accepts two values - on and off --get-magic-repair checks if repairing of magical items is enabled --set-magic-repair= enables/disabled reparis of magical items --get-view-distance= returns view distance set in given slot, accepts slot number, from 0 to 5 --set-view-distance = sets view distance in given slot, accepts slot number, from 0 to 5 and value, from 0 to 255 --list-saves list current saves --list-archived-saves list archived saves --archive-save= archive game from given slot, accepts slot number, from 0 to 5 --archive-all-saves archives all saves --restore-save = restores given archived save into requested slot, accepts save description and target slot, the save description is in form --