
######################################################################
#
#  sawfish.pl - WM-specific code file for wmtheme
#

$tosite = 'sawmill.themes.org';
$badnamechars .= '\'\\';
my ($sawfish_version, $client_exe);
if ($> and !-d "$home/.sawfish") {
  choke("there is no directory $home/.sawfish.  Please run Sawfish first.");
}
getversion_sawfish();


  ###
  #
  #  WM_GETDEFAULTDIRS
  #
  ##

sub wm_getdefaultdirs {
  my ($themepath, $dir, @guessdirs);
  my $smversion = getversion_sawfish();
  my $homedir = "$home/.sawfish/themes";
  my $gothomedir = 0;

    ##  Ask Sawfish itself what the directories are

  if ($themepath = `$client_exe -e '(print theme-load-path)' 2>/dev/null`) {
    dbugout("Sawfish theme path = \"$themepath\"")
      if $debug;
    while ($themepath =~ /[ \(]"(.+?)"(?=[ \)])/g) {
      $dir = expandhomedir($1);
      $gothomedir = 1 if $dir eq $homedir;
      dbugout("Sawfish theme dir: $dir") if $debug;
      if ($dir =~ /\Q$smversion\E/) {
        unshift @guessdirs, $dir;
      } else {
        push @guessdirs, $dir;
      }
    }
    if (!$gothomedir and $> and @guessdirs) {
      unshift @guessdirs, $homedir;
    }
  }

    ##  If Sawfish wasn't able to provide any, guess

  if (!@guessdirs) {
    @guessdirs = (
      "$home/.sawfish/themes",
      "/usr/local/share/sawfish/$smversion/themes",   # Default ...
      "/usr/local/share/sawfish/themes",
      "/usr/share/sawfish/$smversion/themes",         # Debian/Red Hat
      "/usr/share/sawfish/themes"
      );
  }
  if ($> and !-d $homedir) {
    mkdir $homedir, 0755 or
      choke("can't make required directory $homedir: $!");
  }
  verify_themedirs(0, @guessdirs);
}

  ###
  #
  #  WM_SCANDIR
  #
  ###

sub wm_scandir {
  my $dir = shift;
  my ($oid, $entry, $tartest, $name, $mtime);

  dbugout("scanning $dir") if $debug;
  $oid = (stat $dir)[4];
  $mtime = (stat _)[9];
  opendir DH, $dir or choke("can't opendir $dir: $!");
  while (defined($entry = readdir DH)) {
    next if $entry =~ /^\.\.?$/;

    if (-d "$dir/$entry") {
      if (-f "$dir/$entry/theme.jl") {
        createthemerec($entry, "$dir/$entry", $oid);
      }
       ## fixme - what archive types will Sawfish accept?
    } elsif ($entry =~ /(.+)\.(tar\.gz|tgz)$/) {
      createthemerec($1, "$dir/$entry", $oid);
    }
  }
  ($dir, $mtime);
}


  ###
  #
  #  WM_INSTALLTHEME
  #
  ###

sub wm_installtheme {
  my ($location, $possiblename, $defname) = @_;
  my ($themeloc, $themename, $destdir);

  unless (-d $location) {
    choke("can't install a theme from $location - directory required");
  }

## check the $possiblename (archive name), or the subdir name below

###  Determine destination directory

  if ($> == 0) {
    if (!$globalthemedir) {
      choke("no global theme directory could be identified",
        "perhaps Sawfish is not installed on this system?");
    }
    $destdir = $globalthemedir;
  } elsif (!$localthemedir) {
    choke("internal error: no \$localthemedir");
  } else {
    $destdir = $localthemedir;
  }

  $themeloc = findsubdirwithfile($location, 'theme.jl') or
    choke("bad theme - no \"theme.jl\" found");

  if ($defname) {
    $themename = $defname;
  } else {
    if ($themeloc eq $location) {
      if ($possiblename =~ /(.+?)(\.(tgz|tar\.gz|tar\.Z|tar\.bz2|zip|[^\.]+))?$/) {
        $themename = $1;
      } else {
        choke("can't determine theme name from \"$possiblename\"");
      }
    } elsif ($themeloc =~ m|([^/]+)$|) {
      $themename = $1;
    } else {
      choke("can't determine theme name from \"$themeloc\"");
    }
  }

  $themename = checkname($themename);

  syscmd('mv', $themeloc, "$destdir/$themename");

  createthemerec($themename, "$destdir/$themename", $>);
  $themename = setname_sawfish($themename, "$destdir/$themename") ||
    $themename;
  sawfish_compresstheme($themename);
  $themename;
}

  ###
  #
  #  SETNAME_SAWFISH
  #
  ###

sub setname_sawfish {
  my ($themename, $themedir) = @_;
  my ($name_set, $save_nameset, $internal_name);
  my $themetext = slurpfile("$themedir/theme.jl");

  unless ($themetext =~ /(\(\s*theme-name\s+'([^()\s]+)[()\s])/s
    or $themetext =~ /(\(\s*theme-name\s+\(quote\s+([^()]+?)\s*\)\s*\))/s
    or $themetext =~ /(\(\s*add-frame-style\s+'([^()\s]+)[()\s])/s
    or $themetext =~ /(\(\s*add-frame-style\s+\(quote\s+([^()]+?)\s*\)\s*[()])/s)
  {
    complain("warning: theme.jl contains no theme-name");
    return;
  }

  $name_set = $1;
  $internal_name = $2;

  $qthemename = jl_quotage($themename);

  if ($internal_name ne $themename) {
    dbugout("modifying ${themename}'s theme.jl")
      if $debug;
    $save_nameset = $name_set;
    $name_set =~ s/\Q$internal_name\E/$qthemename/;
    $themetext =~ s/\Q$save_nameset\E/$name_set/;
    stowfile("$themedir/theme.jl", $themetext);
  }

  $themename;
}

  ###
  #
  #  WM_ACTIVATETHEME
  #
  ###

sub wm_activatetheme {
  my $themename = shift;
  my $results;
  my $command;

  $command = qq/\Q$client_exe\E -e '(setq default-frame-style (quote /
    . jl_quotage($themename) . qq/)) 2>&1'/;
  chomp($result = `$command`);

  if ($result =~ /^error\b/) {
    complain("$programname: error setting theme:", $result);
    return;
  }

  chomp($result = `\Q$client_exe\E -e '(reframe-all-windows)' 2>&1`);

  if ($result =~ /^error\b/) {
    complain("$programname: error setting theme:", $result);
    return;
  }

}

  ###
  #
  #  WM_UNINSTALLTHEME
  #
  ###

sub wm_uninstalltheme {
  my $themename = shift;

  dirwipe($themes{$themename}{path}, 1);
}

  ###
  #
  #  WM_RENAME
  #
  ###

sub wm_rename {
  my ($old, $new) = @_;
  my $recompress;

  if (exists $themes{$new}) {
    choke("\"$new\" already exists");
  }

  if (-f $themes{$old}{path}) {
    sawfish_decompresstheme($old) or choke();
    $recompress = 1;
  }

  my $newpath = $themes{$old}{path};

  $newpath =~ s/\/\Q$old\E([^\/]*)$/\/$new$1/ or
    choke("internal error: can't find \"/$old\[...]\" in \"$newpath\"");
  rename $themes{$old}{path}, $newpath or
    choke("can't rename \"$themes{$old}{path}\" to \"$newpath\": $!");
  setname_sawfish($new, $newpath);

  if ($recompress) {
    $themes{$new}{path} = $newpath;
    sawfish_compresstheme($new) or choke();
    return ($themes{$new}{path}, $new);
  }

  ($newpath, $new);
}

  ###
  #
  #  WM_VERSIONOK
  #
  ###

sub wm_versionok {
  my $request = shift;
  my $smver = getversion_sawfish();
  $smver =~ s/^\D*(\d+\.\d+).*$/$1/;

  if ($smver and $request =~ /(\d+(\.\d*)?)/) {
    dbugout("judging version \"$request\"") if $debug;
    $rqver = $1;
    if ($smver < 0.22) {
      return $rqver < 0.22
    } elsif ($smver < 0.27) {
      return $rqver > 0.18 and $rqver < 0.27;
    } elsif ($smver < 0.41) {
      return $rqver > 0.26
    } else {
      return minorvermatch($request, $smver);
    }
  } else {
    dbugout("can't figure out version request \"$request\"") if $debug;
    return 1;
  }
}

sub getversion_sawfish {
  if (!defined $sawfish_version) {
    my $response;

    $sawfish_version = '';

    if ($response = `sawfish --version`) {
      $client_exe = 'sawfish-client';
      $wm_executable = 'sawfish';
    } else {
      choke("can't figure out Sawfish's version");
    }

    if ($response =~ /version\s+(\d\S+)/) {
      $sawfish_version= $1;
      dbugout("dealing with Sawfish version $sawfish_version") if $debug;
    } else {
      choke("can't figure out Sawfish's version");
    }
  }

  $sawfish_version;
}

sub sawfish_compresstheme {
  my ($theme, $explicit) = @_;

  dbugout("$theme ($themes{$theme}{path})") if $debug;
  unless (-d $themes{$theme}{path}) {
    if ($explicit) {
      complain("$programname: can't compress $theme, not in a directory");
    }
    return;
  }

  my $tempdir = gettempdir('sawfish_compresstheme');
  my $themedir = $themes{$theme}{path};
  $themedir =~ s!/[^/]+$!!;
  my $target = "$themedir/$theme.tar.gz";

  if (-e $target) {
    complain("$programname: can't compress $theme, $theme.tar.gz already exists");
    return;
  }

  forktick("tar -C \Q$themedir\E -c \Q$theme\E | gzip > \Q$tempdir/$theme.tar.gz\E");
  syscmd('mv', "$tempdir/$theme.tar.gz", $themedir);
  dirwipe($themes{$theme}{path}, 1);
  $themes{$theme}{path} = $target;
  killtempdir($tempdir);
  1;
}

sub sawfish_decompresstheme {
  my ($theme, $explicit) = @_;

  dbugout("$theme ($themes{$theme}{path})") if $debug;
  unless (-f $themes{$theme}{path} and $themes{$theme}{path} =~ /.\.tar\.gz$/) {
    if ($explicit) {
      complain("$programname: can't decompress $theme, not a tarball");
    }
    return;
  }

  my $tempdir = gettempdir('sawfish_decompresstheme');
  my $themedir = $themes{$theme}{path};
  $themedir =~ s!/[^/]+$!!;
  my $target = "$themedir/$theme";
  if (-e $target) {
    complain("$programname: can't decompress $theme, $target already exists");
    return;
  }

  forktick("gzip -dc \Q$themes{$theme}{path}\E | tar xf - -C \Q$tempdir\E");
  syscmd('mv', "$tempdir/$theme", $themedir);
  unlink $themes{$theme}{path} or
    choke("can't unlink $themes{$theme}{path}: $!");
  $themes{$theme}{path} = $target;
  killtempdir($tempdir);
  1;
}

sub jl_quotage {
  my $s = shift;
  $s =~ s/([ ()`'"#,;\[\]|])/\\$1/g;
  $s;
}

1;

