generate-zbm

#!/usr/bin/env perl
# vim: softtabstop=2 shiftwidth=2 expandtab

use strict;
use warnings;

our $VERSION = '1.8.1';

use Getopt::Long qw(:config no_ignore_case auto_version);
use Pod::Usage qw(pod2usage);
use File::Basename;
use File::Temp qw(tempfile tempdir);
use File::Copy;
use File::stat;
use File::Path qw(make_path remove_tree);
use File::Glob qw(:globally :nocase);
use Sort::Versions;

use Pod::Usage qw(pod2usage);

use Data::Dumper;
$Data::Dumper::Indent   = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Purity   = 1;

use Config::IniFiles;
use Sort::Versions;
use YAML::PP;
use boolean;

use Storable qw( dclone );

use constant REFARRAY => ref [];

sub versionedKernel;
sub latestKernel;
sub createInitramfs;
sub execute;
sub safeCopy;
sub nonempty;
sub cleanupMount;
sub enabled;
sub maxRevision;
sub groupKernels;
sub pruneVersions;
sub purgeFiles;
sub verboseUnlink;
sub convertConfig;
sub convertImageConfig;

BEGIN {
  $SIG{INT}  = \&cleanupMount;
  $SIG{TERM} = \&cleanupMount;
}

my ( %runConf, %config );
my $default_config = "/etc/zfsbootmenu/config.yaml";

$runConf{bootdir} = "/boot";
$runConf{confd}   = "/etc/zfsbootmenu/dracut.conf.d";

GetOptions(
  "version|v=s" => \$runConf{version},
  "kernel|k=s"  => \$runConf{kernel},
  "kver|K=s"    => \$runConf{kernel_version},
  "prefix|p=s"  => \$runConf{kernel_prefix},
  "bootdir|b=s" => \$runConf{bootdir},
  "confd|C=s"   => \$runConf{confd},
  "cmdline|l=s" => \$runConf{cmdline},
  "migrate|m:s" => \$runConf{migrate},
  "config|c=s"  => \$runConf{config},
  "enable"      => \$runConf{enable},
  "disable"     => \$runConf{disable},
  "debug|d"     => \$runConf{debug},
  "help|h"      => sub {
    pod2usage( -verbose => 2 );
    exit;
  },
);

unless ( nonempty $runConf{config} ) {
  $runConf{config} = $default_config;

  # Implicitly request migration if default config does not exist
  unless ( defined $runConf{migrate} or -f $runConf{config} ) {
    printf "Configuration %s does not exist, attempting to migrate\n", $runConf{config};
    $runConf{migrate} = "/etc/zfsbootmenu/config.ini";
  }
}

# If migration explicitly requested or no config file exists, convert it
if ( defined $runConf{migrate} ) {
  my $inifile;

  if ( nonempty $runConf{migrate} ) {
    $inifile = $runConf{migrate};
  } else {
    $inifile = $runConf{config};
    $inifile =~ s/(\.yaml)?$/.ini/i;
  }

  # If possible, make a backup of an existing output file
  my $conf_backup = sprintf( "%s.backup", $runConf{config} );
  if ( -f $runConf{config} and safeCopy( $runConf{config}, $conf_backup ) ) {
    printf "Created backup %s -> %s\n", $runConf{config}, $conf_backup;
  }

  convertConfig( $inifile, $runConf{config} ) or exit 1;
  exit 0;
}

if ( -r $runConf{config} ) {
  eval {
    local $SIG{'__DIE__'};
    my $yaml = YAML::PP->new( boolean => 'boolean' )->load_file( $runConf{config} );
    %config = %$yaml;
  } or do {
    my $error = <<"EOF";
Unable to parse configuration $runConf{config} as YAML.

If this is a legacy configuration, migrate to the new format by running

  $0 --migrate $runConf{config} [ --config <output> ],

where `<output>` is the desired location of the converted file. If you
omit the `--config` option, an output location

  $default_config

will be used by default.

----

EOF
    print $error;

    warn $@ if $@;
    exit 1;
  };
} else {
  printf "Configuration %s does not exist or is unreadable\n", $runConf{config};
  exit 1;
}

if ( $runConf{disable} ) {
  $runConf{enable} = false;
}

if ( defined $runConf{enable} ) {

  $config{Global}{ManageImages} = boolean( $runConf{enable} );

  my $yaml = YAML::PP->new(
    boolean => 'boolean',
    header  => 0,
  );

  $yaml->dump_file( $runConf{config}, \%config );
  my $state = $runConf{enable} ? "true" : "false";
  printf "ManageImages set to '%s' in %s\n", $state, $runConf{config};
  exit;
}

unless ( $config{Global}{ManageImages} ) {
  print "ManageImages not enabled, no action taken\n";
  exit;
}

# Override the location of our specific dracut.conf.d directory
if ( nonempty $config{Global}{DracutConfDir} ) {
  $runConf{confd} = $config{Global}{DracutConfDir};
}

# Ensure our bootloader partition is mounted
$runConf{umount_on_exit} = 0;
if ( nonempty $config{Global}{BootMountPoint} ) {
  my $mounted = 0;

  my @output = execute(qq(mountpoint $config{Global}{BootMountPoint}));
  my $status = pop(@output);
  unless ( $status eq 0 ) {
    print "Mounting $config{Global}{BootMountPoint}\n";
    my @output = execute(qq(mount $config{Global}{BootMountPoint}));
    my $status = pop(@output);
    if ( $status eq 0 ) {
      $runConf{umount_on_exit} = 1;
    } else {
      foreach my $line (@output) {
        print $line;
      }
      printf "Unable to mount %s\n", $config{Global}{BootMountPoint};
      exit $status;
    }
  }
}

# Create a temp directory
# It is automatically purged on program exit
my $dir     = File::Temp->newdir();
my $tempdir = $dir->dirname;

# Config file may provide some default values for command-line args
if ( nonempty $config{Kernel}{Path} and !nonempty $runConf{kernel} ) {
  $runConf{kernel} = $config{Kernel}{Path};
}
if ( nonempty $config{Kernel}{Prefix} and !nonempty $runConf{kernel_prefix} ) {
  $runConf{kernel_prefix} = $config{Kernel}{Prefix};
}

if ( nonempty $config{Kernel}{Version} and !nonempty $runConf{kernel_version} ) {
  $runConf{kernel_version} = $config{Kernel}{Version};
  $runConf{kernel_version} =~ s/%current\b/%{current}/i;
}

if ( nonempty $config{Global}{Version} and !nonempty $runConf{version} ) {
  $runConf{version} = $config{Global}{Version};
}

if ( nonempty $config{Kernel}{CommandLine} and !nonempty $runConf{cmdline} ) {
  $runConf{cmdline} = $config{Kernel}{CommandLine};
}

if ( nonempty $runConf{version} ) {
  $runConf{version} =~ s/%current\b/%{current}/i;
  $runConf{version} =~ s/%\{current\}/$VERSION/i;
} else {
  $runConf{version} = $VERSION;
}

# Map "%current" kernel version to output of `uname r`
if ( nonempty $runConf{kernel_version} and $runConf{kernel_version} =~ /%\{current\}/i ) {
  my @uname  = execute(qw(uname -r));
  my $status = pop(@uname);
  unless ( $status eq 0 and scalar @uname ) {
    print "Cannot determine current kernel version\n";
    exit $status;
  }
  chomp @uname;
  $runConf{kernel_version} =~ s/%\{current\}/$uname[0]/i;
}

if ( nonempty $runConf{kernel} ) {

  # Make sure the provided kernel file exists
  unless ( -f $runConf{kernel} ) {
    printf "The provided kernel %s was not found, unable to continue\n", $runConf{kernel};
    exit 1;
  }
} else {

  # Try to determine a kernel file when one was not provided
  if ( nonempty $runConf{kernel_version} ) {
    $runConf{kernel} = versionedKernel $runConf{kernel_version};
    unless ( nonempty $runConf{kernel} ) {
      print "Unable to find file for kernel version $runConf{kernel_version}\n";
      exit 1;
    }
  } else {
    $runConf{kernel} = latestKernel;
    unless ( nonempty $runConf{kernel} ) {
      print "Unable to find latest kernel; specify version or path manually\n";
      exit 1;
    }
  }
}

# Try to determine kernel_prefix or kernel_version if necessary
unless ( nonempty $runConf{kernel_prefix} and nonempty $runConf{kernel_version} ) {

  # Kernel version comes from either file name or internal strings
  unless ( nonempty $runConf{kernel_version} ) {
    $runConf{kernel_version} = kernelVersion( $runConf{kernel} );
    unless ( nonempty $runConf{kernel_version} ) {
      printf "Unable to determine kernel version from %s\n", $runConf{kernel};
      exit 1;
    }
  }

  unless ( nonempty $runConf{kernel_prefix} ) {

    # Prefix is basename of file, less any "-<version>" suffix
    $runConf{kernel_prefix} = basename( $runConf{kernel} );
    $runConf{kernel_prefix} =~ s/-\Q$runConf{kernel_version}\E$//;
    unless ( nonempty $runConf{kernel_prefix} ) {
      printf "Unable to determine kernel prefix from %s\n", $runConf{kernel};
      exit 1;
    }
  }
}

printf "Creating ZFSBootMenu %s from kernel %s\n", $runConf{version}, $runConf{kernel};

# Create a unified kernel/initramfs/command line EFI file
if ( enabled $config{EFI} ) {
  my $unified_efi = createInitramfs( $tempdir, $runConf{kernel_version}, $runConf{kernel} );

  my $efi_target;

  my $efi_prefix = sprintf( "%s/%s", $config{EFI}{ImageDir}, $runConf{kernel_prefix} );
  Log("Setting \$efi_prefix: $efi_prefix");

  my $efi_versions = int $config{EFI}{Versions};

  make_path $config{EFI}{ImageDir};

  if ( $efi_versions > 0 ) {
    Log("EFI.Versions is $efi_versions");

    # Find UEFI bundles and group by apparent version
    my @efi        = glob sprintf( "%s-*.EFI", $efi_prefix );
    my $efi_groups = groupKernels( \@efi, $efi_prefix, ".EFI" );
    Log($efi_groups);

    # Determine the revision to use for this image
    my $revision = maxRevision( $efi_groups->{ $runConf{version} }, ".EFI" ) + 1;
    $efi_target = sprintf( "%s-%s_%s.EFI", $efi_prefix, $runConf{version}, $revision );
    Log("Setting \$efi_target: $efi_target");

    # Attempt to copy the file, clean up if it does not
    unless ( safeCopy( $unified_efi, $efi_target, 0 ) ) {
      verboseUnlink( $efi_target, "Failed to create $efi_target" );
      exit 1;
    }

    # Prune the old versions
    pruneVersions( $efi_groups, $runConf{version}, $efi_versions );
  } else {
    $efi_target = sprintf( "%s.EFI", $efi_prefix );

    # Copy to a placeholder location to ensure success
    my ( $efi_fh, $efi_tempfile ) = tempfile( "zbm.XXXXXX", DIR => $config{EFI}{ImageDir}, UNLINK => 0 );
    close $efi_fh;

    unless ( safeCopy( $unified_efi, $efi_tempfile, 0 ) ) {
      verboseUnlink( $efi_tempfile, "Failed to create $efi_target" );
      exit 1;
    }

    # Roll backups
    my $efi_backup = sprintf( "%s-backup.EFI", $efi_prefix );
    if ( -f $efi_target and rename( $efi_target, $efi_backup ) ) {
      printf "Created backup %s -> %s\n", $efi_target, $efi_backup;
    }

    unless ( rename( $efi_tempfile, $efi_target ) ) {
      verboseUnlink( $efi_tempfile, "Failed to create $efi_target" );
      exit 1;
    }
  }

  printf "Created new UEFI image %s\n", $efi_target;
}

# Create a separate kernel / initramfs. Used by syslinux/extlinux/grub.
if ( enabled $config{Components} ) {
  my $initramfs = createInitramfs( $tempdir, $runConf{kernel_version} );

  my ( $kernel_target, $initramfs_target );

  my $component_prefix   = sprintf( "%s/%s", $config{Components}{ImageDir}, $runConf{kernel_prefix} );
  my $component_versions = int $config{Components}{Versions};

  make_path $config{Components}{ImageDir};

  if ( $component_versions > 0 ) {

    # Find ZBM kernels and group by apparent version
    my @kernels     = glob( sprintf( "%s-*", $component_prefix ) );
    my $kern_groups = groupKernels( \@kernels, $component_prefix );

    my $revision = maxRevision( $kern_groups->{ $runConf{version} } ) + 1;
    $kernel_target = sprintf( "%s-%s_%s", $component_prefix, $runConf{version}, $revision );
    $initramfs_target =
      sprintf( "%s/initramfs-%s_%s.img", $config{Components}{ImageDir}, $runConf{version}, $revision );

    unless ( safeCopy( $initramfs, $initramfs_target, 0 ) ) {
      verboseUnlink( $initramfs_target, "Failed to create $initramfs_target" );
      exit 1;
    }

    unless ( safeCopy( $runConf{kernel}, $kernel_target, 0 ) ) {
      verboseUnlink( $kernel_target,    "Failed to create $kernel_target" );
      verboseUnlink( $initramfs_target, "" );
      exit 1;
    }

    # Prune old versions of the kernel
    pruneVersions( $kern_groups, $runConf{version}, $component_versions );

    # Map each kernel to initramfs and prune those too
    keys %$kern_groups;
    while ( my ( $kver, $image ) = each %$kern_groups ) {
      foreach (@$image) {
        s/\Q$component_prefix\E/$config{Components}{ImageDir}\/initramfs/;
        s/$/.img/;
      }
    }
    pruneVersions( $kern_groups, $runConf{version}, $component_versions );
  } else {
    $kernel_target    = sprintf( "%s-bootmenu",               $component_prefix );
    $initramfs_target = sprintf( "%s/initramfs-bootmenu.img", $config{Components}{ImageDir} );

    # Copy to a placeholder location to ensure success
    my ( $init_fh, $init_tempfile ) = tempfile( "init.XXXXXX", DIR => $config{Components}{ImageDir}, UNLINK => 0 );
    close $init_fh;

    unless ( safeCopy( $initramfs, $init_tempfile, 0 ) ) {
      verboseUnlink( $init_tempfile, "Failed to create $initramfs_target" );
      exit 1;
    }

    my ( $kern_fh, $kern_tempfile ) = tempfile( "kern.XXXXXX", DIR => $config{Components}{ImageDir}, UNLINK => 0 );
    close $kern_fh;

    unless ( safeCopy( $runConf{kernel}, $kern_tempfile, 0 ) ) {
      verboseUnlink( $kern_tempfile, "Failed to create $kernel_target" );
      verboseUnlink( $init_tempfile, "" );
      exit 1;
    }

    # Roll backups
    my $kernel_backup = sprintf( "%s-backup", $kernel_target );
    if ( -f $kernel_target and rename( $kernel_target, $kernel_backup ) ) {
      printf "Created backup %s -> %s\n", $kernel_target, $kernel_backup;
    }

    my $initramfs_backup = sprintf( "%s/initramfs-bootmenu-backup.img", $config{Components}{ImageDir} );
    if ( -f $initramfs_target and rename( $initramfs_target, $initramfs_backup ) ) {
      printf "Created backup %s -> %s\n", $initramfs_target, $initramfs_backup;
    }

    unless ( rename( $init_tempfile, $initramfs_target ) ) {
      verboseUnlink( $init_tempfile, "Failed to create $initramfs_target" );
      verboseUnlink( $kern_tempfile, "" );
      exit 1;
    }

    unless ( rename( $kern_tempfile, $kernel_target ) ) {
      verboseUnlink( $kern_tempfile, "Failed to create $kernel_target" );
      exit 1;
    }
  }

  printf "Created initramfs image %s\n", $initramfs_target;
  printf "Created kernel image %s\n",    $kernel_target;
}

# Generate syslinux.cfg, requires components to be built
if ( enabled $config{Components}{syslinux} ) {
  my $glob    = sprintf( "%s/%s-*", $config{Components}{ImageDir}, $runConf{kernel_prefix} );
  my @listing = sort versioncmp glob($glob);

  # Filter EFI files, in case they're in the same directory
  my @components;
  foreach my $entry (@listing) {
    if ( $entry =~ /EFI$/i ) {
      next;
    }
    push( @components, $entry );
  }

  $runConf{syslinux_temp} = join( '/', $tempdir, 'syslinux.conf' );
  open CFG, '>', $runConf{syslinux_temp};

  my $header = <<'EOF';
UI menu.c32
PROMPT 0

MENU TITLE Boot Menu
TIMEOUT 50
EOF

  print CFG $header;

  my $add_default = 1;
  while (@components) {
    my $entry = pop(@components);

    my $directory = dirname($entry);

    # Strip the mountpoint prefix out to generate a correct path based on /
    $directory =~ s/\Q$config{Global}{BootMountPoint}//;

    my $kernel = basename($entry);
    my ( undef, $version ) = split( '-', $kernel );
    my $label      = "ZFSBootMenu-$version";
    my $menu_label = "ZFSBootMenu $version";

    if ($add_default) {
      print CFG "DEFAULT $label\n\n";
      $add_default--;
    }

    my $entry_text = <<"EOF";
LABEL $label
MENU LABEL $menu_label
KERNEL $directory/$kernel
INITRD $directory/initramfs-$version.img
APPEND $runConf{cmdline}

EOF
    print CFG $entry_text;

  }
  close CFG;

  make_path dirname( $config{Components}{syslinux}{Config} );
  safeCopy( $runConf{syslinux_temp}, $config{Components}{syslinux}{Config} ) or exit 1;
}

END {
  cleanupMount;
}

# Finds specifically versioned kernel in /boot
sub versionedKernel {
  my ( $kver, ) = @_;

  foreach my $prefix (qw(vmlinuz linux vmlinux kernel)) {
    my $kernel = join( '/', ( $runConf{bootdir}, join( '-', ( $prefix, $kver ) ) ) );
    if ( -f $kernel ) {
      return $kernel;
    }
  }

  return;
}

# Finds the latest kernel in /boot, if possible
sub latestKernel {
  my @prefixes = ( "vmlinuz*", "vmlinux*", "linux*", "kernel*" );

  for my $prefix (@prefixes) {
    my $glob = join( '/', ( $runConf{bootdir}, $prefix ) );
    my %kernels;

    for my $kernel ( glob($glob) ) {
      my $version = kernelVersion($kernel);
      next unless defined($version);
      Log("Identified version $version for kernel $kernel");
      $kernels{$version} = $kernel;
    }

    next unless ( keys %kernels );

    for ( sort { versioncmp( $b, $a ) } keys %kernels ) {
      Log("Latest kernel: $_");
      return $kernels{$_};
    }
  }

  return;
}

# Attempts to determine a version for the given kernel, by
#
# a. Identifying the first version-looking string in the file, or
# b. Identifying a version-like part in the name of the file
#
# If one of these exists and not the other, that value is used; if both exist,
# the name-derived value is used if that version string can be matched
# somewhere in the file contents, otherwise the version is undefined.
sub kernelVersion {
  my $kernel = shift;

  my ( $filever, $namever );

  # Consider an unreadable file to have no version
  unless ( -r $kernel ) {
    Log("Unable to read path $kernel, assuming no version");
    return;
  }

  # Read version from the file name, if possible
  basename($kernel) =~ m/-([0-9]+\.[0-9]+\.[0-9]+.*)/;
  if ( defined $1 ) {
    $namever = $1;
  }

  # Read strings in the kernel to recover a version, if possible
  my @output = execute(qq(strings $kernel));
  my $status = pop(@output);
  if ( $status eq 0 ) {
    for (@output) {

      # Versions are any three dot-separated numbers followed by non space
      next unless (/([0-9]+\.[0-9]+\.[0-9]+\S+)/);

      my $ver = $1;

      # First version match is always the file version
      $filever = $ver unless ( nonempty $filever );

      # When there is no version from the file name, we have a match
      last unless ( nonempty $namever );

      # A version that equals the file version supersedes the first match
      if ( $namever eq $ver ) {
        $filever = $ver;
        last;
      }
    }
  }

  # If only one is defined, that's the version
  unless ( nonempty $filever ) {
    Log("No version found in kernel strings, using $namever from path $kernel");
    return $namever;
  }

  unless ( nonempty $namever ) {
    Log("No version found in path $kernel, using $filever from kernel strings");
    return $filever;
  }

  # Warn if the two alternatives do not agree
  if ( $namever ne $filever ) {
    my $warning = <<"EOF";
WARNING: ignoring inconsistent versions in kernel $kernel:
  Path suggests version $namever.
  Kernel strings suggest version $filever.
  To use this kernel, explicitly specify the path and version.
EOF
    print $warning;
    return;
  }

  return $namever;
}

# Returns the path to an initramfs, or dies with an error
sub createInitramfs {
  my ( $imagedir, $kver, $kernfile ) = @_;

  my $output_file = join( '/', $imagedir, "zfsbootmenu.img" );

  my @cmd = ( qw(dracut -q -f --confdir), $runConf{confd} );

  if ( defined $config{Global}{DracutFlags} ) {
    if ( ref $config{Global}{DracutFlags} eq REFARRAY ) {
      foreach my $flag ( @{ $config{Global}{DracutFlags} } ) {
        push( @cmd, $flag );
      }
    } else {
      push( @cmd, $config{Global}{DracutFlags} );
    }
  }

  # If $kernfile is provided, make a unified EFI image with the named kernel
  if ( defined $kernfile ) {
    if ( nonempty $config{EFI}{Stub} ) {
      push( @cmd, ( qq(--uefi-stub), $config{EFI}{Stub} ) );
    }

    push( @cmd, ( qw(--uefi --kernel-image), $kernfile ) );

    if ( nonempty $runConf{cmdline} ) {
      push( @cmd, qq(--kernel-cmdline=\"$runConf{cmdline}\") );
    }

    $output_file = join( '/', $imagedir, "zfsbootmenu.efi" );
  }

  push( @cmd, ( $output_file, $kver ) );

  my $command = join( ' ', @cmd );
  Log("Executing: $command");

  my @output = execute(@cmd);
  my $status = pop(@output);
  if ( $status eq 0 ) {
    foreach my $line (@output) {
      Log($line);
    }
    return $output_file;
  } else {
    foreach my $line (@output) {
      print $line;
    }
    print "Failed to create $output_file\n";
    exit $status;
  }
}

sub execute {
  ( @_ = qx{@_ 2>&1}, $? >> 8 );
}

sub safeCopy {
  my ( $source, $dest, $savetime ) = @_;

  my $preserve = ( defined $savetime ) ? boolean($savetime) : true;
  Log("safeCopy called with: $source, $dest, $preserve");

  unless ( copy( $source, $dest ) ) {
    printf "Unable to copy %s to %s: %s\n", $source, $dest, $!;
    return 0;
  }

  if ($preserve) {

    # Copy the access and mod times if possible
    my $sb = stat $source;
    utime( $sb->atime, $sb->mtime, $dest );
  }

  return 1;
}

sub nonempty {
  my $item = shift;
  return ( defined $item and length $item );
}

sub enabled {
  my $section = shift;
  return ( defined $section->{Enabled} and $section->{Enabled} );
}

sub cleanupMount {
  my $signal = shift;

  if ( $runConf{umount_on_exit} ) {
    print "Unmounting $config{Global}{BootMountPoint}\n";
    execute(qq(umount $config{Global}{BootMountPoint}));
  }

  if ( defined $signal ) {
    print "$0 terminating on signal $signal\n";
    exit 1;
  }
}

sub maxRevision {
  my ( $files, $suffix ) = @_;
  my $revision = 0;

  $suffix = "" unless ( defined $suffix );

  foreach my $file (@$files) {
    if ( $file =~ /_(\d+)\Q$suffix\E$/ ) {
      $revision = $1 if ( $1 > $revision );
    }
  }

  Log("maxRevision discovered: $revision");
  return $revision;
}

sub groupKernels {
  my ( $kernels, $prefix, $suffix ) = @_;
  my %groups;

  $suffix = "" unless ( defined $suffix );

  foreach my $kernel (@$kernels) {
    next unless ( $kernel =~ /^\Q$prefix\E-(.+)_\d+\Q$suffix\E$/ );
    push( @{ $groups{$1} }, $kernel );
  }

  return \%groups;
}

sub pruneVersions {
  my ( $versions, $current, $keep ) = @_;
  my $old_version;

  Log("pruneVersions called with: $current, $keep");
  Log($versions);

  $keep = 0 unless ( defined $keep and $keep gt 0 );

  # Keep revisions current version
  purgeFiles( $versions->{$current}, $keep );

  # Sort the versions and remove the current
  my @old_versions = sort versioncmp keys %$versions;

  my $index = 0;
  foreach my $key (@old_versions) {
    if ( $key eq $current ) {
      splice( @old_versions, $index, 1 );
    } else {
      $index++;
    }
  }

  # Purge all of the too-old revisions
  while ( scalar @old_versions > $keep ) {
    $old_version = shift @old_versions;
    purgeFiles( $versions->{$old_version} );
  }

  # Purge all but the remaining revision of the leftover versions
  foreach $old_version (@old_versions) {
    purgeFiles( $versions->{$old_version}, 1 );
  }
}

sub purgeFiles {
  my ( $files, $keep ) = @_;

  return unless ( defined $files );

  $keep = 0 unless ( defined $keep and $keep gt 0 );

  if ( $keep gt 0 ) {
    my @sorted_files = sort versioncmp @$files;
    while ( scalar @sorted_files > $keep ) {
      my $file = shift @sorted_files;
      verboseUnlink $file;
    }
  } else {
    foreach my $file (@$files) {
      verboseUnlink $file;
    }
  }
}

sub verboseUnlink {
  my ( $file, $message ) = @_;

  return unless ( -f $file );

  # If a message is defined, display regardless of unlink success
  if ( defined $message and ( $message ne "" ) ) {
    print "$message\n";
  }

  if ( unlink $file ) {

    # Print a default success message if none was defined
    print "Removed file $file\n" unless ( defined $message );
  } else {
    print "ERROR: unable to remove $file: $!\n";
  }
}

sub convertConfig {
  my ( $inifile, $configfile ) = @_;

  unless ( -r $inifile ) {
    printf "Unable to read legacy configuration file %s\n", $inifile;
    exit 1;
  }

  print "Migrating $inifile to $configfile\n";

  my %ini_config;
  tie %ini_config, 'Config::IniFiles', ( -file => $inifile );

  my $yaml = YAML::PP->new(
    boolean => 'boolean',
    header  => 0,
  );

  # Force boolean
  $ini_config{Global}{ManageImages} = boolean( $ini_config{Global}{ManageImages} );

  # Convert the component and EFI image sections to the new format
  convertImageConfig $ini_config{Components};
  convertImageConfig $ini_config{EFI};

  # Move syslinux to be a sub section of Components
  $ini_config{Components}{syslinux} = dclone( $ini_config{syslinux} );
  $ini_config{Components}{syslinux}{Enabled} = boolean( $ini_config{Components}{syslinux}{CreateConfig} );
  delete $ini_config{Components}{syslinux}{CreateConfig};
  delete $ini_config{syslinux};

  $yaml->dump_file( $configfile, \%ini_config );

  printf "Please verify the converted file %s\n", $configfile;
}

sub convertImageConfig {
  my $section = shift;

  $section->{Enabled} = boolean( $section->{Copies} > 0 );
  $section->{Enabled} = boolean( $section->{Copies} > 0 );

  if ( $section->{Versioned} ) {
    if ( $section->{Copies} > 1 ) {
      $section->{Versions} = int $section->{Copies};
    } else {
      $section->{Versions} = true;
    }
  } else {
    $section->{Versions} = false;
  }

  delete $section->{Versioned};
  delete $section->{Copies};
}

sub Log {
  my $entry = shift;

  return unless $runConf{debug};
  chomp($entry);
  unless ( ref($entry) ) {
    print STDERR "## $entry\n";
  } else {
    print STDERR Dumper($entry);
  }
}

__END__

=head1 NAME

B<generate-zbm> - ZFSBootMenu initramfs generator

=head1 SYNOPSIS

B<generate-zbm> [options]

=head1 OPTIONS

Where noted, command-line options supersede options in the B<generate-zbm>(5) configuration file.

=over 4

=item B<--version|-v> I<zbm-version>

Override the ZFSBootMenu version; supersedes I<Global.Version>

=item B<--kernel|-k> I<kernel-path>

Manually specify a specific kernel; supersedes I<Kernel.Path>

=item B<--kver|-K> I<kernel-version>

Manually specify a specific kernel version; supersedes I<Kernel.Version>

=item B<--prefix|-p> I<image-prefix>

Manually specify the output image prefix; supersedes I<Kernel.Prefix>

=item B<--confd|-C> I<confd-path>

Specify the dracut configuration directory; supersedes I<Global.DracutConfDir>

=item B<--cmdline|-l> I<options>

Override the kernel command line; supersedes I<Kernel.CommandLine>

=item B<--bootdir|-b> I<boot-path>

Specify the path to search for kernel files; default: I</boot>

=item B<--config|-c> I<conf-file>

Specify the path to a configuration file; default: I</etc/zfsbootmenu/config.yaml>

=item B<--migrate|-m> [I<ini-config>]

Migrate a legacy INI file to the new YAML format, writing the converted file to the path specified by B<--config>. If I<ini-config> is not specified, a default path is chosen by removing any I<.yaml> suffix in the B<--config> path and appending a I<.ini> suffix.

=item B<--enable>

Set the I<Global.ManageImages> option to true, enabling image generation.

=item B<--disable>

Set the I<Global.ManageImages> option to false, disabling image generation.

=item B<--debug|d>

Enable debug output

=back

=head1 SEE ALSO

B<generate-zbm>(5) B<zfsbootmenu>(7)

=head1 AUTHOR

ZFSBootMenu Team L<https://github.com/zbm-dev/zfsbootmenu>

=cut