#!/usr/bin/perl -w

######################################################################
#
#  WMTHEME - window manager theme utility
#
#
#  Author:   Joshua Swink  <jswink@pacbell.net>
#
#  wmtheme is released under the GNU General Public License.
#  See the file COPYING. If that file is missing, see
#  http://www.gnu.org/copyleft/gpl.html

require 5.005;

use vars qw(
  $themedata_was_read
  $themes_were_scanned
  $themedata_modified
  $userconfig_read
  %unsupported
  $dont_extract
  $tosite
  $lockname
  $preinst_callback
  $badnamechars
  $no_run_check
  %tempdirs
  $tmpnum
  $tmpbase
  $processtable_ok
  $processtable_checked
  );

use Carp;
use Getopt::Long;
use File::Find;
Getopt::Long::Configure('bundling');

$VERSION = '1.3.2';
$PREFIX = '/usr/local';

$| = 1;
($programname = $0) =~ s/(.*)\///;
$programdir = $1 || '.';
$home = $ENV{HOME} || $ENV{LOGDIR} or choke("can't determine \$HOME");
chomp($uname_srm = `uname -srm`);
$badnamechars = '<>';
$tmpbase = $ENV{TMPDIR} || '/tmp';
unless (-d $tmpbase and -x _ and -w _) {
  choke("Can't use temporary directory $tmpbase: doesn't exist or inaccessible");
}

$libdir = "$PREFIX/lib/wmtheme";
$wmthemedir = "$home/.wmtheme";
$wmthemeconf = "$wmthemedir/conf";
($wm_name, $wm_supportfile) = get_wm_specific_names($programname);
checkcwd();

foreach (qw(PIPE INT HUP TERM)) {
  $SIG{$_} = \&sigcatcher;
}

@rdffields = qw(
  id
  origname
  link
  updated
  author
  category
  size
  version
  );

@themefields = (qw(
  updatable
  path
  owner
  mtime
  validated
  local_updated
  ), @rdffields);

process_options();
finish();


#============================================================================
#  CHECKCWD
#  ensure existence of current directory, without producing warnings
#============================================================================

sub checkcwd {
  if (exists $ENV{PWD} and ! -d $ENV{PWD}) {
    complain ("$programname: directory '$ENV{PWD}' doesn't exist");
    if (chdir $home) {
      complain("$programname: operating from $home");
    } else {
      choke("can't operate from $home: $!");
    }
  }
}

#============================================================================
#  PROCESS_OPTIONS
#  interpret command line and call appropriate functions
#============================================================================

sub process_options {
  my %options;

  { # Block this out to localize the %SIG modification

    # Redirect GetOptions error messages through choke()
    local $SIG{__WARN__} = sub { choke(grep s/\n?$//, (my @foo = @_,
      "try $programname -h for help.")) };

    if (!GetOptions(
      'help|h|?',         \$options{help},
      'version|V',        \$options{version},
      'install|i=s',      \$options{install},
      'justinstall|I=s',  \$options{justinstall},
      'uninstall|u=s',    \$options{uninstall},
      'list|l',           \$options{list},
#      'get|g=s',          \$options{get},
#      'download|d=s',     \$options{download},
      'debug|D'  ,        \$options{debug},
      'backout|b',        \$options{backout},
      'backmany|B',       \$options{backmany},
      'favorite|f:s',     \$options{favorite},
      'setup',            \$options{setup},
      'random|R',         \$options{random},
      'rename|r=s',       \$options{rename},
#      'update',           \$options{update},
      'info',             \$options{info},
#      'manage|m',         \$options{manage},
      'review',           \$options{review}
        )) {
      exit 1;
    } 
  }

    ##  Check for incompatible options

  if ($options{manage} and $options{info}) {
    choke("options 'manage' and 'info' cannot be used together.");
  }

  if ($options{backout} and $options{backmany}) {
    choke("options -b and -B conflict");
  }

    ##  Deal with options that don't require the window manager-specific
    ##  support file

  $debug = 1 if $options{debug};

  if ($options{version})     {
    print "$programname $VERSION\n";
    finish()
  }

  $options{help}        and  printhelp();

    ##  Deal with options that actually do something

  include_wmcode($wm_supportfile);
    
  defined $options{install}     and  install_from_archive($options{install}, 1);
  defined $options{justinstall} and  install_from_archive($options{justinstall});
  defined $options{uninstall}   and  uninstall_theme($options{uninstall});
  defined $options{get}         and  get_theme($options{get});
  defined $options{download}    and  download_theme($options{download});
  $options{list}        and  listthemes();
  $options{backout}     and  backout();
  $options{backmany}    and  backoutmany();
  defined $options{favorite} and set_favorite_theme($options{favorite});
  defined $options{rename}   and rename_theme($options{rename}, shift @ARGV);
  $options{setup}       and  setup_wmtheme();
  $options{info}        and  theme_info();
  $options{update}      and  update_themes();
  $options{manage}      and  manage_themes();
  $options{random}      and  random_theme();
  $options{review}      and  review_themes();

    ##  Do activating or listing, the default behaviors

  if (@ARGV) {
    activate_themes(@ARGV);
    @ARGV = ();
  } else {
    foreach (keys %options) {
      return if defined $options{$_} and $_ ne 'debug';
    }
    listthemes();
  }
}

#============================================================================
#  PRINTHELP
#  print usage summary
#============================================================================

sub printhelp {
  print
"Usage: $programname [OPTION]... THEME
Manage $wm_name themes. The default action on the specified theme
is to activate it.

      <theme> [theme...]   (no option) Activate a theme.  Multiple themes
                           will be shown one after another, with prompting.
  -b, --backout            Uninstall the most recently installed theme
  -B, --backmany           Ask about removing each recently installed theme
"#  -d  --download <theme>   Download theme archive but don't install
."  -f, --favorite [theme]   Activate or set favorite theme
"#  -g, --get <theme>        Download, install, and activate a theme
."  -i, --install <archive>  Install and activate a theme from archive
  -I, --justinstall <archive>  Install theme from archive, don't activate
  -h, --help               Print this usage help
  -l, --list               List installed themes
"#  -m, --manage [theme...]  Set updating options on specified themes (or all)
."  -R, --random             Activate a random theme
  -r, --rename <old> <new> Rename a theme
  -u, --uninstall <theme>  Uninstall a theme
  -V, --version            Print version information and exit
  -D, --debug              Enable debugging output
      --info [theme...]    Print specified themes' update info (or all)
      --setup              Create ~/.wmtheme with a sample configuration file
"#      --update             Get newest versions of identified themes
."      --review             Display all themes in turn, with option to remove

";
  finish();
}

#============================================================================
#  WRITE_THEMEDATA
#  save WM-specific data (themes and misc. settings)
#  called on termination
#============================================================================

sub write_themedata {
  if ($themedata_was_read and $themedata_modified) {
    _write_themedata();
  }
}

 #  usefontsupport - returns boolean

sub usefontsupport {
  read_userconfig();
  return exists $config_wm{tempfontdir};
}

#============================================================================
#  RANDOM_THEME
#  used with option -R/--random: activate a theme at random
#============================================================================

sub random_theme {
  my $rtheme;
  scan_themes();
  my @themes = keys %themes;

  if (@themes == 1) {
    complain("$programname: -R isn't very useful with just one theme.");
  } elsif (!@themes) {
    complain("$programname: there are no themes.");
  } else {
    $rtheme = rand @themes;
    if (exists $loginfo{lastrandom} and
        $themes[$rtheme] eq $loginfo{lastrandom}) {
      splice @themes, $rtheme, 1;
      $rtheme = rand @themes;
    }
    activate_theme($themes[$rtheme], 1);
    $loginfo{lastrandom} = $themes[$rtheme];
    $themedata_modified = 1;
  }
}

#============================================================================
#  REVIEW_THEMES
#  See all themes in turn, with an opportunity to remove
#============================================================================

sub review_themes {
  my ($theme, $choice, $isowner);

  if ($unsupported{activation}) {
    choke("Sorry, can't review themes in $wm_name.");
  }
  if (!$no_run_check and !is_running($wm_executable)) {
    choke("can't activate; $wm_executable is not running");
  }

  scan_themes();

  print "Press enter for next, q to quit, u to uninstall (* = owned by you)\n";
  REVIEW: foreach $theme (sort { lc $a cmp lc $b } keys %themes) {
    wm_activatetheme($theme);
    $isowner = (!$> or $themes{$theme}{owner} == $>);
    print '*' if $isowner;
    print " --==: $theme :==-- ";
    while (1) {
      $choice = <STDIN>;
      if ($choice =~ /^[qQ]/) {
        last REVIEW;
      } elsif ($choice =~ /^[uU]/) {
        if ($isowner) {
          print "Uninstall $theme, are you sure? [y/N] ";
          $choice = <STDIN>;
          if ($choice =~ /^[yY]/) {
            if (wm_uninstalltheme($theme)) {
              logaction('uninstall', $theme);
              print "$theme uninstalled.\n";
              $themedata_modified = 1;
            } else {
              complain("Uninstallation failed!");
            }
          }
        } else {
          complain("Can't uninstall $theme, you are not its owner.");
        }
        last;
      } elsif ($choice =~ /\S/) {
        print "Press enter for next, q to quit, u to uninstall (* = owned by you) ";
      } else {
        last;
      }
    }
  }
}

#============================================================================
#  ACTIVATE_THEMES
#  interactively activate several themes
#============================================================================

sub activate_themes {
  my @themes = @_;
  my ($themename, $showprompt, %shown);

  foreach (@themes) {
    $themename = identify_installed_theme($_);
    next if $shown{$themename};
    if ($showprompt) {
      print "Press enter to see $themename: ";
      <STDIN>;
    }
    return unless activate_theme($themename, 1);
    $shown{$themename} = 1;
    $showprompt = 1;
  }
}

#============================================================================
#  ACTIVATE_THEME
#  make a theme visible.  it's mainly a wrapper around wm_activatetheme()
#============================================================================

sub activate_theme {
  my ($themename, $explicit) = @_;

  if ($unsupported{activation}) {
    warn "$programname: theme activation is not supported\n" if $explicit;
    return;
  }
  if (!$no_run_check and !is_running($wm_executable)) {
    warn "$programname: can't activate; $wm_executable is not running\n"
      if $explicit;
    return;
  }
  unless ($>) {
    warn "$programname: activation as root is not recommended\n" if $explicit;
    return;
  }

  if (!(defined $activated_theme)
       or $activated_theme ne $themename
       or $explicit)
  {
    print "$programname: activating $themename\n";
    wm_activatetheme($themename, 1);
    $activated_theme = $themename;
    return 1;
  }
}

#============================================================================
#  LISTTHEMES
#  display list of themes to user.  the default.  also with -l/--list
#============================================================================

sub listthemes {
  my ($owner, %uthemes, $maxlen, @lines);
  my ($rows, $cols) = screensize();

  scan_themes();
  unless (%themes) {
    print "$programname: no themes found.\n";
    return;
  }
  $maxlen = 1;

    ##  Gather up lists of themes, per owner

  foreach (keys %themes) {
    $owner = $themes{$_}{owner};
    if (!exists $uthemes{$owner}) {
      $uthemes{$owner}{list} = [];
      if (!$owner) {
        $uthemes{$owner}{name} = 'Global';
      } elsif ($owner == $>) {
        $uthemes{$owner}{name} = 'Local';
      } else {
        $uthemes{$owner}{name} = getpwuid($owner);
      }
    }
    push @{$uthemes{$owner}{list}}, $_;
    $maxlen = length $_ if length $_ > $maxlen;
  }

    ##  Print current user's themes first, followed by other normal users,
    ##  and lastly root

  foreach (sort
    {
      if    ($a == $b) {  0 }
      elsif ($a == $>) { -1 }
      elsif ($b == $>) {  1 }
      elsif ($a == 0)  {  1 }
      elsif ($b == 0)  { -1 }
      else { lc $uthemes{$a}{name} cmp lc $uthemes{$b}{name} }
    }
    keys %uthemes) {
      @lines = makecolumns($maxlen + 2, 0,
        sort {lc $a cmp lc $b} @{$uthemes{$_}{list}});
      print "\n$uthemes{$_}{name}\n", '-' x length($lines[0]), "\n",
        join("\n", @lines), "\n";
  }
  print "\n";
}


#============================================================================
#  UNINSTALL_THEME
#  remove a theme.  used with -u/--uninstall.  mostly a wrapper around
#  wm_uninstalltheme().  this sub handles ownership checks and confirmation.
#============================================================================

sub uninstall_theme {
  my $themetext = shift;
  my $theme;

  $themetext eq '' and choke("Uninstall what?");
  my @matches = soft_identify($themetext, 1, 1)
    or choke("no themes match \"$themetext\"");

  if ($themes{$matches[0]}{owner} != $> and $>) {
    choke("cannot uninstall $matches[0]: you are not its owner");
  }

  if (@matches > 1) {
    print "There are " . @matches . " possible matches for $themetext:\n\n";
    my $choice = getuserchoice(@matches);
    finish('uninstall cancelled.') if $choice < 0;
    $theme = $matches[$choice];
  } else {
    $theme = $matches[0];
  }

  print "Really delete theme \"$theme\"? [y/N] ";
  if (<STDIN> !~ /^[yY]/) {
    print "$programname: NOT uninstalling $theme.\n";
  } elsif (wm_uninstalltheme($theme)) {
    logaction('uninstall', $theme);
    print "$programname: $theme uninstalled.\n";
  } else {
    choke("uninstallation failed!");
  }
}

#============================================================================
#  GET_THEME
#  used with -g/--get.  download, install, and activate a theme.
#============================================================================

sub get_theme {
  my $request = shift;
  my ($newtheme, $name, $tempdir, $url, $filename, $location, $themename);

  $request eq '' and choke("Get what?");
  $tosite or choke("Sorry, $programname cannot download themes.");

  include_wmcode('wm_download.pl');
  scan_themes();
  preinst_check();

    ## dlquery() gives us a reference to a hash of theme info,
    ## with the same fields as the hashes stored in %themes.  its
    ## info has come from t.o's RDF response to searches, and thus
    ## the download link is present.

  ($newtheme, $name) = dlquery($request, $tosite);
  $name = checkname($name);
  $url = parse_url($newtheme->{link});
  $tempdir = gettempdir();

  ($filename) = downloadfile($url, $tempdir, !$dont_extract, 1);
  if ($dont_extract) {
    $location = "$tempdir/$filename";
    getarchivefonts($location);
  } else {
    $location = $tempdir;
    install_fonts($tempdir);
  }
  dbugout("installing from $location") if $debug;
  $themename = wm_installtheme($location, $filename, $name);

    ## wm_installtheme() is expected to create a brand new entry
    ## in the global %themes, so to preserve t.o's info, merge the stuff
    ## gotten above in $newtheme

  rdfmerge($themename, $newtheme);
  $themes{$themename}{updatable} = 'yes';
  $themes{$themename}{local_updated} = $$newtheme{updated};
  killtempdir($tempdir);
  logaction('install', $themename);
  activate_theme($themename) or
    print "$programname: installed \"$themename\"\n";
}

#============================================================================
#  INSTALL_FROM_ARCHIVE
#  used with -i/--install.  extract, install, and activate a theme from
#  an archive file.
#============================================================================

sub install_from_archive {
  my ($filename, $activate) = @_;
  my ($extractcmd, $tempdir, $themename, $copy);

  $filename eq '' and choke("Install what?");
  scan_themes();
  preinst_check();
  $tempdir = gettempdir();
  if (!$dont_extract and
      $extractcmd = get_extractcmd($filename, $tempdir, 0)) {
    forktick($extractcmd);
    modtree($tempdir);
    install_fonts($tempdir);
    dbugout("installing from $tempdir") if $debug;
    $themename = wm_installtheme($tempdir, $filename);
  } else {
    ($copy = $filename) =~ s/.*\///;
    copyfile($filename, "$tempdir/$copy");
    $filename = "$tempdir/$copy";
    getarchivefonts($filename);
    dbugout("installing from $filename") if $debug;
    $themename = wm_installtheme($filename, $filename);
  }

  logaction('install', $themename);
  print "$programname: installed \"$themename\"\n";
  activate_theme($themename) if $activate;
}

#============================================================================
#  DOWNLOAD_THEME
#  used with -d/--download.  download a theme.  it's saved as an archive
#  file, i.e. not extracted or installed.
#============================================================================

sub download_theme {
  my $themename = shift;
  my ($filename, $newtheme, $url, $name);

  $tosite or choke("Sorry, $programname cannot download themes.");
  $themename eq '' and choke("Download what?");

  include_wmcode('wm_download.pl');
  ($newtheme, $name) = dlquery($themename, $tosite);
  $url = parse_url($$newtheme{link});
  ($filename) = downloadfile($url, '.', 0, 1);
  print "$programname: wrote $filename\n";
}

#============================================================================
#  THEME_INFO
#  used with --info.  print the record (from ~/.wmtheme/<invocation>.data)
#  for several themes.
#============================================================================

sub theme_info {
  my @themes = splice @ARGV;
  my ($arg, $themename, $rkey, @rkeys, $maxkeylen, $shownorecord, $any);

  $maxkeylen = getmaxlen(@themefields);
  scan_themes();

  if (@themes) {
    $shownorecord = 1;
  } else {
    scan_themes();
    @themes = sort keys %themes;
  }

  foreach $arg (@themes) {
    $themename = identify_installed_theme($arg, 1);

    if (!$themename) {
      print "$arg: no such theme.\n";
    } elsif (exists $themes{$themename}) {
      @rkeys = ();
      foreach (keys %{$themes{$themename}}) {
        push @rkeys, $_ if $themes{$themename}{$_} ne '';
      }
      print "Theme $themename:\n";
      foreach $rkey (sort @rkeys) {
        print ' ' x ($maxkeylen + 2 - length($rkey)),
          "$rkey -> $themes{$themename}{$rkey}\n";
      }
      $any = 1;
      print "\n";
    } elsif ($shownorecord) {
      print "$themename: no record.\n";
    }
  }
  if (!($any or $shownorecord)) {
    print "$programname: there are no update records.\n";
  }
}

#============================================================================
#  LOGACTION
#  make note of an installation/uninstallation.  this allows -b/-B to know
#  what themes to deal with.  also resets the recorded timestamp of the
#  directory in question, so caching is still effective.
#============================================================================

sub logaction {
  my ($action, $themename) = @_;
  return unless -d $wmthemedir;

  cache_themedir($themename);

  if ($action eq 'uninstall') {
    for (my $i = 0; $i < @installlog; ++$i) {
      if ($installlog[$i] eq $themename) {
        splice(@installlog, $i, 1);
        last;
      }
    }
    delete $themes{$themename};
  } elsif ($action eq 'install') {
    push @installlog, $themename;
  } else {
    choke("internal error: logactioned passed action \"$action\"");
  }

  $loginfo{lastaction} = $action;
  $themedata_modified = 1;
}

#============================================================================
#  BACKOUT
#  used with -b/--backout.  kills the most recently installed theme.
#============================================================================

sub backout {
  my $doomedtheme;

  scan_themes();
  read_userconfig();

  if (!-d $wmthemedir) {
    print "$programname: Cannot back out of theme installations.\n";
    lecture_setup();
    return;
  }

  if (!@installlog) {
    print "$programname: there are no themes to back out\n";
    return;
  }

  $doomedtheme = pop @installlog;
  while (@installlog and !$themes{$doomedtheme}) {
    $doomedtheme = pop @installlog;
  }

  unless (exists $themes{$doomedtheme}) {
    print "$programname: there are no themes to back out\n";
    $loginfo{lastaction} = 'uninstall';
    $themedata_modified = 1;
    return;
  }

  if ($config_wm{confirm_first_backout} ne 'no'
      or $loginfo{lastaction} ne 'install')
  {
    print "$programname: remove $doomedtheme? [y/N] ";
    if (<STDIN> !~ /^[yY]/) {
      print "$programname: cancelled.\n";
      $loginfo{lastaction} = 'uninstall';
      $themedata_modified = 1;
      return;
    }
  }

  if (!wm_uninstalltheme($doomedtheme)) {
    choke("uninstallation of $doomedtheme failed");
  }

  logaction('uninstall', $doomedtheme);
  print "$programname: $doomedtheme uninstalled\n";
  if ($config_wm{set_favorite_on_backout} eq 'yes' and $loginfo{favorite}
      and $themes{$loginfo{favorite}}) {
    activate_theme($loginfo{favorite});
  }
}

#============================================================================
#  BACKOUTMANY
#  used with -B/--backmany.  interactively validates or removes all
#  recently installed themes.  note that answering "no" to a theme
#  means that it's accepted and won't be affected by -b/-B any more.
#============================================================================

sub backoutmany {
  my ($doomedtheme, @keptthemes, $answer, $uninstalled_last);

  scan_themes();
  read_userconfig();

  if (!-d $wmthemedir) {
    print "$programname: Cannot back out of theme installations.\n";
    lecture_setup();
    return;
  } elsif (@installlog) {
    $activated_theme = $installlog[-1];
  } else {
    print "$programname: there are no themes to back out\n";
    return;
  }

  # any theme not uninstalled must be unshifted onto @keptthemes
  while (@installlog) {
    $uninstalled_last = 0;
    $doomedtheme = pop @installlog;
    next unless $themes{$doomedtheme};
    if ($config_wm{set_queried_backout} eq 'yes') {
      activate_theme($doomedtheme);
    }
    print "Remove \"$doomedtheme\"? [y/N/a/q/h] ";
    $answer = <STDIN>;

    if ($answer =~ /^[yY]/) {
      if (!wm_uninstalltheme($doomedtheme)) {
        choke("uninstallation of $doomedtheme failed");
      }
      cache_themedir($doomedtheme);
      delete $themes{$doomedtheme};
      $uninstalled_last = 1;
      $loginfo{lastaction} = 'uninstall';
      print "$programname: $doomedtheme uninstalled\n";
    } elsif ($answer =~ /^[qQ]/) {
      unshift @keptthemes, $doomedtheme;
      unshift @keptthemes, @installlog;
      last;
    } elsif ($answer =~ /^[aA]/) {
      push @installlog, $doomedtheme;
      $activated_theme = '';  ## Make _sure_ it tries to activate $doomedtheme
      activate_theme($doomedtheme, 1);
    } elsif ($answer =~ /^[hH]/) {
      push @installlog, $doomedtheme;
      print "$programname: Commands for interactive backing out:
  y - uninstall the theme
  n - keep the theme (default)
  a - activate theme and ask again
  q - quit
  h - print help\n";
    } elsif ($answer !~ /^(?:[Nn]|\s*$)/) {
      push @installlog, $doomedtheme;
      chomp $answer;
      print "\"$answer\" not understood: Press h for help.\n";
    }
  }
  if ($uninstalled_last and $config_wm{set_favorite_on_backout} and
    $loginfo{favorite} and $themes{$loginfo{favorite}}) {
    activate_theme($loginfo{favorite});
  }
  $themedata_modified = 1;
}

#============================================================================
#  SET_FAVORITE_THEME
#  used with -f/--favorite.  with a name: it becomes the  favorite.  without,
#  activates whatever the favorite is.
#============================================================================

sub set_favorite_theme {
  my $newfavorite = shift;

  if ($unsupported{activation}) {
    warn "$programname: theme activation is not supported\n";
    return;
  }

  scan_themes();

    # Match against /./ -- this causes a command like the following to
    # be ignored:  wmtheme -f ""
  if ($newfavorite =~ /./) {
    if (!-d $wmthemedir) {
      print "$programname: The directory $home/.wmtheme must be created to store the\n";
      print "  favorite theme's name.  Do you want it created now? [Y/n] ";
      return unless ask_setup();
    }

    my $truefavorite = identify_installed_theme($newfavorite);
    $loginfo{favorite} = $truefavorite;
    $themedata_modified = 1;
    print "$programname: $truefavorite is now the favorite theme for $wm_name.\n";
    return;
  }

  if ($loginfo{favorite} eq '') {
    print "$programname: No favorite theme has been specified.\n";
    print "$programname: Use $programname -f <theme> to set the favorite theme.\n";
    return;
  }

  scan_themes();
  if ($themes{$loginfo{favorite}}) {
    activate_theme($loginfo{favorite}, 1);
  } else {
    choke("the favorite theme \"$loginfo{favorite}\" doesn't seem to be installed");
  }
}

#============================================================================
#  RENAME_THEME
#============================================================================

sub rename_theme {
  my ($oldname, $newname) = @_;

  choke("theme renaming is not supported") if $unsupported{renaming};

  if (!defined $newname or $newname eq '') {
    choke("rename requires a new name for the theme");
  }

  choke("theme names can't have a newline character") if $newname =~ /\n/;

  if (($newname =~ /\// and $programname ne 'itheme') or
      ($newname =~ m!/.*/!)) {
    choke("theme names can't have a /");
  }

  if ($newname =~ /[\Q$badnamechars\E]/) {
    choke("$wm_name themes may not contain these characters: $badnamechars");
  }

  scan_themes();
  if (defined $themes{$newname}) {
    choke("a theme called \"$newname\" already exists.");
  }

  my @matches = soft_identify($oldname, 1, 1)
    or choke("no themes match \"$oldname\"");
  my $current;

  if ($themes{$matches[0]}{owner} != $> and $>) {
    choke("cannot rename $matches[0], you are not its owner");
  }

  if (@matches > 1) {
    print "There are " . @matches . " possible matches for $oldname:\n\n";
    my $choice = getuserchoice(@matches);
    finish('rename cancelled') if $choice < 0;
    $current = $matches[$choice];
  } else {
    $current = $matches[0];
  }

  my ($newpath, $setname) = wm_rename($current, $newname);
  cache_themedir($current);
  $newname = $setname if $setname;
  $themes{$newname} = $themes{$current};
  $themes{$newname}{path} = $newpath;
  delete $themes{$current};

  if (exists $loginfo{favorite} and $loginfo{favorite} eq $current) {
    $loginfo{favorite} = $newname;
    dbugout("\"$current\" was the favorite, recording the change")
      if $debug;
  }

  $themedata_modified = 1;
  print "$programname: $current is now known as $newname\n";
}

#============================================================================
#  LECTURE_SETUP
#  whine about no ~/.wmtheme dir.  only happens when you've asked the
#  program to do something that requires this dir.
#============================================================================

sub lecture_setup {
  print "  No installations have been recorded because the directory
  $wmthemedir does not exist. Do you want to set up wmtheme
  to record theme installations? [Y/n] ";

  return ask_setup();
}

sub ask_setup {
  if (<STDIN> =~ /^(?:[Yy]|\s*$)/) {
    setup_wmtheme();
    return 1;
  }
  0;
}


  #########################################################################
  #                                                                       #
  #                       THEME MANAGEMENT UTILITIES                      #
  #                                                                       #
  #########################################################################


  #########################################################################
  #
  #  VERIFY_THEMEDIRS
  #
  #  Receives a list of potential theme directories. Verifies that they
  #  are accessible, and sets the global and local theme directories.
  #
  #  Returns a list of verified directories. Unless the first parameter
  #  is true, returns only the global and/or local directores. If it
  #  was true, returns all accessible directories.
  #

sub verify_themedirs {
  my ($keepall, @dirs) = @_;
  my (%verified, $s, $dir);

  foreach $dir (@dirs) {
    if (-d $dir and -x _ and -r _) {
      $s = (stat _)[4];
      if (!$s) {
        if (!$globalthemedir) {
          $globalthemedir = $dir;
          dbugout("Global directory is $globalthemedir") if $debug;
          $verified{$dir} = 1;
        }
      } elsif (!$localthemedir and $> and $s == $>) {
        $localthemedir = $dir;
        dbugout("Local directory is $localthemedir") if $debug;
        $verified{$dir} = 1;
      }
      $verified{$dir} = 1 if $keepall;
    }
  }

  keys %verified;
}

  #########################################################################
  #
  #  GETTEMPDIR
  #
  #  Make a temporary directory and return its name
  #  Side effect: it's marked for removal upon program exit (in %tempdirs)
  #
  #  INPUTS:
  #           a string - not important to the program, but may be useful
  #                      for debugging, if for example the program pauses
  #                      during an error so that temporary directories
  #                      may be examined
  #
  #           dontmkdir - (optional, boolean) if true, the directory
  #                      won't be created in this sub.
  #
  # OUTPUT:
  #           name of the directory - may be passed to killtempdir()
  #                       if and when the caller determines that the
  #                       directory is no longer needed


sub gettempdir {
  my $key = shift || 'default';
  my $dontmkdir = shift || 0;
  my $tmpdir;

  $tmpdir = "$tmpbase/$programname.$key.$$";
  $tmpnum ||= 0;

  do {
    $tmpnum++;
  } while (exists $tempdirs{"$tmpdir.$tmpnum"} or
           -e "$tmpdir.$tmpnum");

  $tmpdir .= ".$tmpnum";
  unless ($dontmkdir) {
    mkdir $tmpdir, 0755 or choke("Can't mkdir $tmpdir: $!");
  }
  $tempdirs{$tmpdir} = 1;
  dbugout($tmpdir) if $debug;
  $tmpdir;
}

sub killtempdir {
  my $tmpdir = shift;

  dbugout("killing $tmpdir") if $debug;
  dirwipe($tmpdir, 1) if -e $tmpdir;
  delete $tempdirs{$tmpdir} if exists $tempdirs{$tmpdir};
}


  #######################################################################
  #
  #  GET_EXTRACTCMD
  #

sub get_extractcmd {
  my ($filename, $tempdir, $piped) = @_;
  my ($uncompress, $extractcmd, $zipquiet);

  my $qfilename = quotemeta $filename;
  my $qtempdir = quotemeta $tempdir;

  dbugout("examining $filename") if $debug;

  if ($filename =~ /\.zip$/i) {
    # zip, what a bother

    $zipquiet = $debug ? '' : ' -q';

    if ($piped) {
      $extractcmd = " cat > \Q$tmpbase\E/$qfilename; unzip$zipquiet -d $qtempdir \Q$tmpbase\E/$qfilename; rm -f \Q$tmpbase\E/$qfilename";
    } else {
      $extractcmd = "unzip$zipquiet -d $qtempdir $qfilename";
    }

  } else {
    if ($filename =~ /\.(?:tar\.gz|tgz|etheme)$/) {
      $uncompress = $piped ? 'gzip -dc' : "gzip -dc $qfilename";
    } elsif ($filename =~ /\.tar\.bz2$/) {
      $uncompress = $piped ? 'bzip2 -d' : "bzip2 -dc $qfilename";
    } elsif ($filename =~ /\.tar\.Z$/) {
      $uncompress = $piped ? 'uncompress -c' : "uncompress -c $qfilename";
    }

    # This is a pretty portable use of tar, so don't change it unless
    # you know what you're doing.  -C (to change dir) usually won't
    # work with -x for example, so no tar xf - -C outdir.
    $extractcmd = "$uncompress | (cd $qtempdir && tar -xf -)" if $uncompress;
  }

  if ($extractcmd) {
    dbugout("returning $extractcmd") if $debug;
    return $extractcmd;
  } else {
    dbugout("unrecognized, returning nothing") if $debug;
    return '';
  }

}

  #######################################################################
  #
  #  IDENTIFY_INSTALLED_THEME
  #
  #  Given a possible name, return the actual name of a matching
  #  installed theme. Do a case insensitive substring search if
  #  there's no exact match.
  #
  #  The program will abort, if the theme doesn't exist, unless a second
  #  "true" parameter is supplied
  #

sub identify_installed_theme {
  my ($themename, $dontabort) = @_;

  if ($themename =~ /\n/) {
    choke("illegal newline character in theme name \"\Q$themename\E\"");
  }
  scan_themes();

  # Check for
  #   a) exact
  #   b) case insensitive
  #   c) case insensitive substring not including /
  #      (for IceWM, forces substring of a base theme get the base theme)
  #   d) case insensitive substring

  if ($themelist =~ m|\n\Q$themename\E\n|) {
    return $themename;
  } elsif ($themelist =~ m|\n(\Q$themename\E)\n|i) {
    return $1;
  } elsif ($themelist =~ m|\n([^/\n]*\Q$themename\E[^/\n]*)\n|i) {
    return $1;
  } elsif ($themelist =~ m|\n([^\n]*\Q$themename\E[^\n]*)\n|i) {
    return $1;
  } elsif ($dontabort) {
    return;
  }
  choke("no installed theme found matching $themename");
}

  #######################################################################
  #
  #  SOFT_IDENTIFY
  #
  #  Given a possible name, return all installed themes that match
  #  the name as a case-insensitive substring.
  #
  #  (set $writepriv to true to only get writable/removable/owned ones)
  #  (set $atleastone to true to get one back, even if $writepriv was
  #   true and no writable matches could be found)

sub soft_identify {
  my ($themename, $writepriv, $atleastone) = @_;
  my (@matches, $single);

  scan_themes();
  while ($themelist =~ m|\n([^\n]*\Q$themename\E[^\n]*)(?=\n)|ig) {
    if (!$writepriv or !$> or $themes{$1}{owner} == $>) {
      push @matches, $1;
    } elsif (!@matches and $atleastone and !$single) {
      $single = $1;
    }
  }

  @matches = ($single) if !@matches and $single;
  sort @matches;
}

  #######################################################################
  #
  #  CHECKNAME
  #
  #  Removes disallowed characters from a proposed name, and asks the
  #  user to supply a different name if it's already used.  Returns
  #  a usable name in any case.
  #

sub checkname {
  my $proposed = shift;
  my $newname;

  $proposed =~ s/[\Q$badnamechars\E]//g;

  if (exists $themes{$proposed}) {
    print "$programname: a theme named \"$proposed\" already exists.\n";
    print "Enter a different name for this theme (or just press enter to cancel)\n: ";
    chomp ($newname = <STDIN>);
    while (exists $themes{$newname}) {
      print "That theme exists. Please enter a different name, or <enter> to cancel: ";
      chomp($newname = <STDIN>);
    }
    $newname || finish('bye.');
  } else {
    $proposed;
  }
}


  #########################################################################
  #                                                                       #
  #                            GENERAL UTILITIES                          #
  #                                                                       #
  #########################################################################

  #  Attention:  is_running and sigbyname
  #  Tested on:  Linux
  # Not tested:  AIX, FreeBSD, OpenBSD, SunOS

sub sigbyname {
  my ($sig, $prog) = @_;
  my $pid;

  if ($pid = pidbyname($prog)) {
    dbugout("sending $sig to $pid ($prog)") if $debug;
    kill $sig, $pid;
  } else {
    dbugout("can't get pid of $prog") if $debug;
  }
}

sub is_running { &pidbyname }

sub pidbyname {
  my $prog = shift;
  my ($pid, $uname);

  unless ($runningcache{$prog}) {
    ($uname) = $uname_srm =~ /^(\w+)/ or return;

    if ($uname eq 'Linux') {
      ($pid) = `ps -o pid,comm -C "$prog"` =~ /^\s*(\d+)\s+\Q$prog\E\b/m;
    } elsif ($uname eq 'FreeBSD' or $uname eq 'OpenBSD') {
      ($pid) = `ps -o pid,command` =~ /^\s*(\d+)\s+\Q$prog\E\b/m;
    } elsif ($uname eq 'AIX' or $uname eq 'SunOS') {

# See http://www.rs6000.ibm.com/doc_link/en_US/a_doc_lib/cmds/aixcmds4/ps.htm

      ($pid) = `ps -do pid,comm` =~ /^\s*(\d+)\s+\Q$prog\E\b/m;
    } else {
      # Using Proc::ProcessTable is slow, so it's the last choice
      $pid = useprocesstable($prog);
    }

    $runningcache{$prog} = $pid if $pid;
  }

  $runningcache{$prog} || undef;
}

sub useprocesstable {
  my $prog = shift;
  my ($table, $p);

  if (startprocesstable()) {
    $table = new Proc::ProcessTable;
    foreach $p (@{$table->table}) {
      return $p->{pid} if $p->{fname} eq $prog;
    }
  }

  0;
}

sub checkpidavail {
  return if $uname_srm =~ /^(?:Linux|FreeBSD|OpenBSD|SunOS|AIX)\b/ or
    startprocesstable();
  print
"Notice:  Themes cannot currently be activated on this platform.  You can
enable activation by either 1) installing the Perl module Proc::ProcessTable,
or 2) informing wmtheme's author how a program may determine a running
program's process ID (for example, by running `ps -do pid,comm`).\n"
}

sub startprocesstable {
  return $processtable_ok if $processtable_checked;
  $processtable_checked = 1;
  eval 'use Proc::ProcessTable;';
  $processtable_ok = $@ ? 0 : 1;
}

sub makethemerec {
  my $rec = {};
  foreach (@themefields) {
    $$rec{$_} = '';
  }
  $rec;
}

#============================================================================
# Calling subs from the supportfiles
#============================================================================

sub scan_themes   { callexternal('_scan_themes',   'wm_data.pl') }
sub setup_wmtheme { callexternal('_setup_wmtheme', 'wm_config.pl') }
sub update_themes { callexternal('_update_themes', 'wm_update.pl') }
sub manage_themes { callexternal('_manage_themes', 'wm_update.pl') }
sub install_fonts { callexternal('_install_fonts', 'wm_fonts.pl', @_)
                    if usefontsupport() }

sub read_userconfig {
  if (!$userconfig_read) {
    dbugout("reading the conf file.") if $debug;
    callexternal('wmconf_read_userconfig', 'wm_config.pl', $wmthemeconf);
    $userconfig_read = 1;
  }
}

sub callexternal {
  my ($sub, $wmfile) = @_;
  include_wmcode($wmfile);
  &{$sub}(@_[2..$#_]);
}

sub include_wmcode {
  my $wmfile = shift;

  if ($debug) {
     # 'require' won't import a file twice, so %include_cache
     # is only meaningful for debugging output
    if ($include_cache{$wmfile}) {
      dbugout("repeated request to include $wmfile (is ignored)");
    } else {
      dbugout("importing $wmfile");
      $include_cache{$wmfile} = 1;
    }
  }

  my $filepath = "$libdir/$wmfile";

  unless (-f $filepath) {
    $filepath = "$programdir/$wmfile";
    choke("can't find support file \"$wmfile\"") unless -f $filepath;
  }

  require $filepath or choke("can't require \"$filepath\": $!");
}

  #######################################################################
  #
  #  GETUSERCHOICE
  #
  #  Receives a list of strings and asks the user to choose one by number.
  #
  #  Returns -1 if user enters 'q' (quit), otherwise the index to the
  #  choice.
  #

sub getuserchoice {
  my @choices = @_;
  my $numchoices = @choices;
  my $maxindent = length($numchoices);
  my $rows = (screensize())[0] - 4;
  my $start = 0;
  my ($input, $i);

  while (1) {
    for ($i = $start; $i < $start + $rows and $i < $numchoices; $i++) {
      print ' ' x ($maxindent - length($i + 1)), $i + 1, ". $choices[$i]\n";
    }
    print "\n[($numchoices matches) enter a # to choose, Q=quit, ENTER=next page, P=previous] ";
    $input = <STDIN>;
    if ($input =~ /^[qQ]/) {
      return -1;
    } elsif ($input =~ /(\d+)/) {
      return $1 - 1 if $1 > 0 and $1 <= $numchoices;
      print "$1 is out of range (press enter) ";
      <STDIN>;
    } elsif ($input =~ /^\s*$/) {
      $start = 0 if ($start += $rows) >= $numchoices;
    } elsif ($input =~ /^[pP]/) {
      if ($start) {
        $start = 0 if ($start -= $rows) < 0;
      } elsif ($numchoices > $rows) {
        $start = $numchoices - $rows;
      }
    } else {
      print "\"$input\" not recognized (press enter) ";
      <STDIN>;
    }
  }
}

sub screensize {
  my $sttyout = `stty -a`;
  my ($rows, $cols);

  $rows = ($sttyout =~ /\brows (\d+)/ and $1 > 4) ? $1 : 24;
  $cols = ($sttyout =~ /\bcolumns (\d+)/ and $1 > 79) ? $1 : 80;
  ($rows, $cols);
}

sub version_ok {
  my $request = shift;

  $versionok_cache{$request} = wm_versionok($request)
    if not exists $versionok_cache{$request};
  $versionok_cache{$request};
}

  # minorvermatch:
  #
  #   Given two dotted version/release strings,  determine whether the first
  #   two numbers of each string match.
  #
  #   "1.3", "1.0":     no
  #   "1.2", "1.2.19":  yes

sub minorvermatch {
  ($_[0] =~ /^[^\d]*(\d*\.\d+)/ and $_[1] =~ /^[^\d]*$1(?!\d)/);
}

sub slurpfile {
  my $filename = shift;
  my $contents;

  dbugout($filename) if $debug;
  open F, $filename or choke("can't read $filename: $!");
  local $/;
  $contents = <F>;
  close F;
  $contents;
}

sub stowfile {
  my ($filename, $filedata) = @_;

  open F, ">$filename" or choke("can't write $filename: $!");
  print F $filedata;
  close F or choke("problem closing $filename after write: $!");
}

sub dirwipe {
  my ($loc, $dirtoo) = @_;
  my $success = 1;

  dbugout("wiping $loc") if $debug;
  return unlink $loc unless -d $loc;

  finddepth(
    sub {
      if (-d $_) {
        rmdir $_ or $success = 0 unless $_ eq '.';
      } else {
        unlink $_ or $success = 0;
      }
    }, $loc);

  rmdir $loc or $success = 0 if $dirtoo;
  $success;
}

sub copyfile {
  my ($file, $newloc) = @_;
  my ($block, $amt);

  dbugout(qq[copying "$file" TO "$newloc"]) if $debug;
  open (FOLD, $file) or choke("can't read $file: $!");
  open (FNEW, ">$newloc") or choke("can't write $newloc: $!");
  while ($amt = read FOLD, $block, 65536) {
    print FNEW $block;
  }
  close FNEW or choke("problem closing $newloc: $!");

  if (defined $amt) {
    close FOLD;
  } else {
    complain("$programname: system error while copying: $!");
    close FOLD or choke("aborting - error closing $file: $!");
    dirwipe($newloc);
    choke();
  }
}

  ##  filefind - like `find -type f`

sub filefind {
  my $dir = shift;
  my @found;

  dbugout("looking in $dir") if $debug;
  find (
    {
      no_chdir => 1,
      wanted => sub { push @found, $_ if -f $_; }
    }, $dir);
  @found;
}

sub findexe {
  my ($prog, @xdirs) = @_;

  foreach (split(/:/, $ENV{PATH}), @xdirs) {
    $_ = expandhomedir($_);
    return "$_/$prog" if -x "$_/$prog" and -f _;
  }
}

sub findsubdirwithfile {
  my ($dir, $filename) = @_;

  dbugout("looking for $filename in $dir") if $debug;
  if (!-f "$dir/$filename") {
    my $found = 0;
    find(
      sub {
        if (-f $_ and $_ eq $filename) {
          $dir = $File::Find::dir;
          $found = 1;
        }
      }, $dir);
    return undef unless $found;
  }
  dbugout("found it in $dir") if $debug;
  $dir;
}

sub modtree {
  my $location = shift;
  my (@ch_dirs, @ch_files);

  dbugout("modding $location") if $debug;
  if (-d $location) {
    find (
      {
        no_chdir => 1,
        wanted =>
          sub {
            if (-d $_) {
              push @ch_dirs, $_;
            } else {
              push @ch_files, $_;
            }
          }
      }, $location);
  } else {
    @ch_files = ($location);
  }

  chown $>, $), @ch_files, @ch_dirs unless $>;
  chmod 0644, @ch_files if @ch_files;
  chmod 0755, @ch_dirs if @ch_dirs;
}

sub getfiletypes {
  my @files = @_;
  my $pretrim = getmaxlen(@files) + 1;
  my $file_input = "$tmpbase/$programname.getfiletypes.$$";

  $cleanups{getfiletypes} = $file_input;

  stowfile($file_input, join("\n", @files) . "\n");

  # Not using file -b due to portability issues.  This means we depend on
  # 'file' formatting its output such that every line begins with the
  # filename and a colon, and is padded with spaces such that the result
  # always begins at the same column.

  my @types = split(/\n/, forktick("file -f \Q$file_input\E | sed -e \Qs;^[^:]*: *;;g\E"));
  unlink $file_input or choke("can't remove temporary file $file_input: $!");

  delete $cleanups{getfiletypes};

  grep { s/^.{$pretrim}\s*// } @types;
}

sub insistdir {
  my $dir = shift;

  return if -d $dir;
  choke("directory $dir is required, but something's in the way") if -e $dir;
  mkdir $dir, 0755 or choke("can't mkdir $dir: $!");
}

sub bytesdisplay {
  my $bytes = shift;
  my $disp;

  if ($bytes == 1) {
    return '1 byte';
  } elsif ($bytes < 8192) {
    $disp = "$bytes bytes";
  } elsif ($bytes < 1048576) {
    $disp = sprintf('%0.1fK', $bytes / 1024);
  } elsif ($bytes < 1073741824) {
    $disp = sprintf('%0.1fM', $bytes / 1048576);
  } else {
    $disp = sprintf('%0.1fG', $bytes / 1073741824);
  }
  $disp =~ s/\.0//;
  $disp;
}

#############################################################################
#
#  MAKECOLUMNS
#
#  Make a list of strings which may be printed to display the supplied list
#  of items in vertical columns.
#
#  Inputs:   cwidth:     Requested column width.  It may be zero, in which
#                        case a reasonable default will be used.
#            swidth:     Screen width.  It may also be zero to indicate that
#                        a default should be used.
#             items:     List of items.
#
#  Output:  A list of strings.

sub makecolumns {
  my ($cwidth, $swidth, @items) = @_;
  my ($item, @ditems, @dlist, $cutwidth, $dispcols, $stable, $disprows, $i, $j);

  $swidth = (screensize())[1] unless $swidth > 0;
  $cwidth = getmaxlen(@items) + 2 unless $cwidth;
  $cwidth = $swidth - 1 if $cwidth >= $swidth;
  $cutwidth = $cwidth - 2 * ($cwidth > 2);
  $dispcols = int($swidth / $cwidth);

  foreach $item (@items) {
    if (length($item) > $cutwidth) {
      push @ditems, substr($item, 0, $cutwidth) . '  ';
    } else {
      push @ditems, $item . ' ' x ($cwidth - length($item));
    }
  }

    ##  $stable = number of stable columns
    ##  (the rest will shift about)

  $stable = @ditems % $dispcols + 1;
  $disprows = int(@ditems / $dispcols);
  ++$disprows if $disprows * $dispcols < @ditems;

    ## pad the display list with empty cells for that fresh-smelling,
    ## sorted-column format.  the first empty cell goes at the bottom
    ## of the last stable column.

  if ($stable > 1) {
    for ($i = $stable; $i <= $dispcols; ++$i) {
      splice(@ditems, $disprows * $i - 2, 1, ($ditems[$disprows * $i - 2], ' '));
    }
  }

  for ($i = 0; $i < $disprows; ++$i) {
    $dlist[$i] = '';
    for ($j = 0; $j < $dispcols; ++$j) {
      $dlist[$i] .= $ditems[$i + $j * $disprows];
    }
  }
  @dlist;
}

sub expandhomedir {
  my $path = shift;

    # from perlfaq5.
  $path =~ s!^~([^/]*)!$1 ? (getpwnam $1)[7] || "~$1" : $home!e;
  $path;
}

sub readcontinuationline {
  my ($fh, $stripbs) = @_;
  my ($line, $in);

  return unless defined($line = <$fh>);

  $line .= $in while $line =~ /\\$/ and defined($in = <$fh>);

  $line =~ s/\\(?:\n|$)//gs if $stripbs;

  $line;
}

sub cgiencode {
  my $encoded = shift;

  $encoded =~ s/([^A-Za-z\d ])/'%' . unpack('H2', $1)/eg;
  $encoded =~ y/ /+/;
  $encoded;
}

sub cgidecode {
  my $encode = shift;

  $encode =~ y/+/ /;
  $encode =~ s/%([A-Fa-f\d]{2})/pack('H2', $1)/eg;
  $encode;
}

sub makecgiline {
  my $line = join('&', map cgiencode($_), @_);
  $line =~ s/&([^&]*)(&|$)/=$1$2/g;
  $line;
}

sub decodecgiline {
  @_ = map cgidecode($_), split /[=&]/, $_[0];
  push @_, '' unless $#_ % 2;
  @_;
}

sub getmaxlen {
  my $maxlen = length shift;
  foreach (@_) {
    $maxlen = length $_ if length $_ > $maxlen;
  }
  $maxlen;
}

sub cache_themedir {
  my $theme = shift;
  my $themedir;

  ($themedir = $themes{$theme}{path}) =~ s|/[^/]+$||;
  if ($themedir) {
    if (-e $themedir) {
      $cached_dirs{$themedir} = (stat _)[9];
      dbugout("caching $themedir -- $cached_dirs{$themedir}") if $debug;
      $themedata_modified = 1;
    } elsif (exists $cached_dirs{$themedir}) {
      delete $cached_dirs{$themedir};
      $themedata_modified = 1;
    }
  }
}

sub get_wm_specific_names {
  my $invocation = shift;
  my $ids = {
              astheme  => ['AfterStep',     'afterstep.pl'],
              bbtheme  => ['Blackbox',      'blackbox.pl'],
              etheme   => ['Enlightenment', 'enlightenment.pl'],
              gotheme  => ['Golem',         'golem.pl'],
              gtktheme => ['GTK',           'gtk.pl'],
              itheme   => ['IceWM',         'icewm.pl'],
              ortheme  => ['Oroborus',      'oroborus.pl'],
              sftheme  => ['Sawfish',       'sawfish.pl'],
              wmtheme  => ['Window Maker',  'wmaker.pl'],
              xmtheme  => ['xmms',          'xmms.pl']
            };

  return @{$ids->{$invocation}} if exists $ids->{$invocation};

  complain("wmtheme: \"$invocation\" is not a valid invocation name");
  exit 1;
}

sub rdfmerge {
  my ($theme, $rdfrec) = @_;

  foreach (@rdffields) {
    $themes{$theme}{$_} = $$rdfrec{$_} unless $$rdfrec{$_} eq '';
  }
}

sub getarchivefonts {

    #  Explode an archive, try to install any fonts found inside,
    #  clean up the mess.  Only necessary when working with a window
    #  manager whose themes we don't want to extract and fool with.
    #  Only AfterStep, actually.

  my $archive = shift;

  return unless usefontsupport();

  my $tempdir = gettempdir('getarchivefonts', 1);
  my $extract = get_extractcmd($archive, $tempdir, 0);

  if ($extract) {
    mkdir $tempdir, 0755 or choke("Can't mkdir $tempdir: $!");
    forktick($extract);
    install_fonts($tempdir);
  }

  killtempdir($tempdir);
}

sub sigcatcher {
  my $signame = shift;

  $SIG{$signame} = 'DEFAULT';

  system('stty', 'echo');  # in case ctrl-c during getpass()
  dbugout("received signal $signame") if $debug;

  print "\n";
  if ($signame eq 'INT') {
    choke("interrupt - quitting.");
  } elsif ($signame eq 'PIPE') {
    choke("broken pipe - aborting.");
  } elsif ($signame eq 'TERM') {
    choke("terminating.");
  } else {
    choke("SIG$signame caught - quitting.");
  }
}

sub dbugout {
  (my $csub = uc ((caller 1)[3])) =~ s/^MAIN:://;
  print STDERR "$csub: ", join("\n$csub: ", @_), "\n";
}

sub syscmd {
  my @cmd = @_;
  dbugout(join(' ', @cmd)) if $debug;
  system(@cmd);
  choke("child error: quitting") if $?;
}

sub forktick {
  my $command = shift;
  my $response;

  dbugout($command) if $debug;
  $response = `$command`;
  if ($?) {
    print $response if $response;
    choke("child error: aborting");
  }
  $response;
}

sub preinst_check {
  &$preinst_callback if defined $preinst_callback;
}

sub cleanup {
  map killtempdir($_), keys %tempdirs;
}

sub complain {
  grep s/\n?$/\n/, my @messages = @_;
  if ($debug) {
    carp @messages;
  } else {
    print STDERR @messages;
  }
}

sub choke {
  cleanup();
  unlink $lockname if $lockname;
  grep s/\n?$/\n/, my @messages = @_;
  if ($debug) {
    croak @messages;
  } else {
    print STDERR @messages;
    exit 1;
  }
}

sub finish {
  foreach (@_) {
    print "$programname: $_\n";
  }
  write_themedata();
  cleanup();
  unlink $lockname if $lockname;
  exit;
}


