#!/usr/bin/perl

# Copyright (C) 2012-2020 Daniel "Trizen" Șuteu <echo dHJpemVueEBnbWFpbC5jb20K | base64 -d>.
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

# Program: obbrowser
# License: GPLv3
# Date: 29 December 2012
# Latest edit: 23 June 2020
# https://github.com/trizen/obbrowser

# Contributors:
#   Daniel Napora - https://github.com/napcok
#   Musikermomo   - https://github.com/Musikermomo

# Recursively browse the filesystem through Openbox pipe menus (with icons)

use 5.014;

#use strict;
#use warnings;

my $pkgname = 'obbrowser';
my $version = 0.13;

our $CONFIG;

my $home_dir =
     $ENV{HOME}
  || $ENV{LOGDIR}
  || (getpwuid($<))[7]
  || `echo -n ~`;

my $db_clean    = 0;
my $config_dir  = "$home_dir/.config/obbrowser";
my $config_file = "$config_dir/config.pl";
my $cache_db    = "$config_dir/cache.db";
my $icons_dir   = "$config_dir/icons";

if (not -d $config_dir) {
    require File::Path;
    File::Path::make_path($config_dir)
      or die "Can't create dir `$config_dir': $!";
}

sub print_usage {
    print <<"USAGE";
usage: $0 [dir]

1. To use this script with Openbox, insert the following
   line in ~/.config/openbox/menu.xml:

        <menu id="obbrowser" label="Disk" execute="$0"/>

2. If "obmenu-generator" is used for generating the Openbox menu,
   insert the following line in ~/.config/obmenu-generator/schema.pl:

        {pipe => ["obbrowser", "Disk", "drive-harddisk"]},

3. For more settings, check out the configuration file:

        $config_file
USAGE
    exit;
}

sub remove_database {
    my ($db) = @_;

    foreach my $file ($db, "$db.dir", "$db.pag") {
        unlink($file) if (-e $file);
    }
}

if (@ARGV and $ARGV[0] eq '-h' || $ARGV[0] eq '--help') {
    print_usage();
}

my $config_documentation = <<"EOD";
#!/usr/bin/perl

# $pkgname - configuration file
# This file is updated automatically.
# Any additional comment and/or indentation will be lost.

=for comment

# ICON SETTINGS

    | use_gtk3         : Use the Gtk3 library for resolving the icon-paths. (default: 0)
    | with_icons       : Use icons for files and directories.
    | mime_ext_only    : Determine the mimetype by extension only. (may improve performance)

    | icon_size        : Preferred size for icons. (default: 48)
    | generic_fallback : Try to shorten icon name at '-' characters before looking at inherited themes. (default: 1)
    | force_icon_size  : Always get the icon scaled to the requested size. (default: 0)
    | gtk_rc_filename  : Absolute path to the GTK configuration file.

# MENU

    | terminal         : Command to a terminal emulator for opening directories.
    | file_manager     : Command to a file manager for opening files and directories.
    | browse_label     : Label for "Browse here..." action.
    | terminal_label   : Laber for "Terminal here..." action.
    | with_terminal    : Include the "Terminal here..." menu entry, to open directories in a terminal.
    | start_path       : Absolute path from which to start to browse the filesystem.
    | dirs_first       : Order directories before files.
    | ignore_dotfiles  : Ignore files starting with a dot.

=cut

EOD

my %CONFIG = (
              file_manager      => 'thunar',
              browse_label      => 'Browse here...',
              terminal_label    => 'Terminal here...',
              terminal_icon     => 'utilities-terminal',
              file_manager_icon => 'folder-open',
              terminal          => 'tilix --working-directory',
              gtk_rc_filename   => "$home_dir/.gtkrc-2.0",
              with_terminal     => 0,
              start_path        => $home_dir,
              dirs_first        => 1,
              with_icons        => 1,
              mime_ext_only     => 0,
              ignore_dotfiles   => 1,
              icon_size         => 48,
              generic_fallback  => 1,
              force_icon_size   => 0,
              use_gtk3          => 0,
              VERSION           => $version,
             );

sub dump_configuration {
    require Data::Dump;
    open my $config_fh, '>', $config_file
      or die "Can't open file '${config_file}' for write: $!";
    my $dumped_config = q{our $CONFIG = } . Data::Dump::dump(\%CONFIG) . "\n";
    $dumped_config =~ s/\Q$home_dir\E/\$ENV{HOME}/g if ($home_dir eq $ENV{HOME});
    print $config_fh $config_documentation, $dumped_config;
    close $config_fh;
}

if (not -e $config_file or -z _) {
    dump_configuration();
}

require $config_file;    # load the configuration file

my @valid_keys = grep exists $CONFIG{$_}, keys %{$CONFIG};
@CONFIG{@valid_keys} = @{$CONFIG}{@valid_keys};

if ($CONFIG{VERSION} != $version) {
    $CONFIG{VERSION} = $version;
    dump_configuration();
}

my $with_icons = $CONFIG{with_icons};

if ($with_icons and not -d $icons_dir) {
    remove_database($cache_db);
    require File::Path;
    File::Path::make_path($icons_dir)
      or warn "$0: can't create icon path `$icons_dir': $!\n";
}

{
    my %table = (
                 '&' => 'amp',
                 '"' => 'quot',
                 "'" => 'apos',
                 '<' => 'lt',
                 '>' => 'gt',
                );

    sub xmlEscape {
        $_[0] =~ tr/&"'<>// ? $_[0] =~ s/([&"'<>])/&$table{$1};/gr : $_[0];
    }
}

sub escapeQuot {
    index($_[0], '&quot;') == -1 ? $_[0] : $_[0] =~ s/&quot;/\\&quot;/gr;
}

sub mk_dir_elem {
    qq{<menu id="$_[0]/$_[2]" label="}
      . ($_[2] =~ s/_/__/gr)
      . qq{" icon="$_[3]" execute="$_[4] &quot;$_[1]/}
      . escapeQuot($_[2])
      . q{&quot;"/>};
}

sub mk_file_elem {
    qq{<item label="}
      . ($_[2] =~ s/_/__/gr)
      . qq{" icon="$_[3]"><action name="Execute"><execute>$CONFIG{file_manager} &quot;$_[1]/}
      . escapeQuot($_[2])
      . q{&quot;</execute></action></item>};
}

# Regenerate the cache db if the config file has been modified
if (!$db_clean and ((-M $config_file) < (-M $cache_db))) {
    print STDERR ":: Regenerating the cache DB...\n";
    remove_database($cache_db);
    $db_clean = 1;
}

eval { require GDBM_File };

dbmopen(my %cache_db, $cache_db, 0777)
  or die "Can't create/access database <<$cache_db>>: $!";

# Regenerate the icon db if the GTKRC file has been modified
if ($with_icons) {
    my $gtkrc_mtime = (stat $CONFIG{gtk_rc_filename})[9];

    if ($db_clean) {
        $cache_db{__GTKRC_MTIME__} = $gtkrc_mtime;
    }
    else {
        my $old_mtime = $cache_db{__GTKRC_MTIME__} // -1;
        if ($old_mtime != $gtkrc_mtime) {
            print STDERR ":: Regenerating the cache DB...\n";

            dbmclose(%cache_db);
            remove_database($cache_db);

            dbmopen(my %cache_db, $cache_db, 0777)
              or die "Can't create database <<$cache_db>>: $!";

            $cache_db{__GTKRC_MTIME__} = $gtkrc_mtime;
        }
    }
}

sub get_icon_path {
    my ($icon_name) = @_;

    state $gtk = do {

        require Digest::MD5;

        $CONFIG{use_gtk3}
          ? do {
            eval "use Gtk3";
            'Gtk3'->init;
            'Gtk3';
          }
          : do {
            require Gtk2;
            'Gtk2'->init;
            'Gtk2';
          };
    };

    state $theme =
      ($gtk eq 'Gtk2')
      ? Gtk2::IconTheme->get_default
      : Gtk3::IconTheme::get_default();

#<<<
    state $flags = "${gtk}::IconLookupFlags"->new(
        [
            ($CONFIG{force_icon_size}  ? 'force-size'        : ()),
            ($CONFIG{generic_fallback} ? 'generic-fallback'  : ()),
        ]
    );
#>>>

#<<<
    my $pixbuf = eval {
        (substr($icon_name, 0, 1) eq '/')
        ? (substr($icon_name, -4) eq '.xpm')
            ? "${gtk}::Gdk::Pixbuf"->new_from_file($icon_name)->scale_simple($CONFIG{icon_size}, $CONFIG{icon_size}, 'hyper')
            : "${gtk}::Gdk::Pixbuf"->new_from_file_at_size($icon_name, $CONFIG{icon_size}, $CONFIG{icon_size})
        : $theme->load_icon($icon_name, $CONFIG{icon_size}, $flags);
    };
#>>>

    if (defined($pixbuf)) {
        my $md5  = Digest::MD5::md5_hex($pixbuf->get_pixels);
        my $path = "$icons_dir/$md5.png";
        $pixbuf->save($path, 'png') if not -e $path;
        return $path;
    }

    return '';
}

{
    my %fast_cache;

    sub check_icon {
        $fast_cache{$_[0] // return ''} //= ($cache_db{$_[0]} //= get_icon_path($_[0]));
    }
}

my $path = @ARGV ? shift(@ARGV) : $CONFIG{start_path};

my (%alias, %icons, @dirs, @files);

opendir(my $dir_h, $path)
  or warn "$0: Can't open dir `$path': $!\n";

foreach my $file (readdir $dir_h) {

    if ($CONFIG{ignore_dotfiles}) {
        next if substr($file, 0, 1) eq q{.};
    }
    else {
        next if ($file eq q{.} or $file eq q{..});
    }

    if ($with_icons) {

        if (-d "$path/$file") {
            push @dirs, [$file, $icons{'inode-directory'} ||= check_icon('inode-directory')];
            next;
        }

        require File::MimeInfo;    # File::MimeInfo::Magic is better, but slower!

        my $mime_type = (
                         (
                          $CONFIG{mime_ext_only}
                          ? File::MimeInfo::globs($file)
                          : File::MimeInfo::mimetype("$path/$file")
                         ) // 'unknown'
                        ) =~ tr|/|-|r;

        $mime_type = $alias{$mime_type} if exists $alias{$mime_type};

        {
            my $type = $mime_type;
            while (1) {
                if ($icons{$type} ||= check_icon($type)) {
                    $alias{$mime_type} = $type;
                    $mime_type = $type;
                    last;
                }
                elsif ($icons{"gnome-mime-$type"} ||= check_icon("gnome-mime-$type")) {
                    $alias{$mime_type} = "gnome-mime-$type";
                    $mime_type = "gnome-mime-$type";
                    last;
                }
                $type =~ s{.*\K[[:punct:]]\w++$}{} || last;
            }
        }

        if (!$icons{$mime_type}) {
            my $type = $mime_type;
            while (1) {
                $type =~ s{^application-x-\K.*?-}{} || last;
                $icons{$type} ||= check_icon($type);
                $icons{$type} && do { $alias{$mime_type} = $type; $mime_type = $type; last };
            }
        }
        push @files, [
            $file, $icons{$mime_type} ||=
              do { $alias{$mime_type} = 'unknown'; check_icon('unknown') }
        ];
    }
    else {
        push @{-d "$path/$file" ? \@dirs : \@files}, [$file, ''];
    }
}

closedir $dir_h;

my $thisDir            = xmlEscape($path);
my $qEscapedDir        = escapeQuot($thisDir);
my $escapedProgramName = xmlEscape($0);

# "Browse here..." and "Terminal here..." entries
my $generated_menu =
    qq{<openbox_pipe_menu><item label="$CONFIG{browse_label}"}
  . ($with_icons ? (qq{ icon="} . check_icon($CONFIG{file_manager_icon}) . q{"}) : '')
  . qq{><action name="Execute">}
  . qq{<execute>$CONFIG{file_manager} &quot;$qEscapedDir&quot;</execute></action></item>}
  . (
     $CONFIG{with_terminal}
     ? (qq{<item label="$CONFIG{terminal_label}"}
        . ($with_icons ? (qq{ icon="} . check_icon($CONFIG{terminal_icon}) . q{"}) : '')
        . qq{><action name="Execute"><execute>$CONFIG{terminal} &quot;$qEscapedDir&quot;</execute></action></item>})
     : q{}
    )
  . q{<separator/>};

my @calls = ([\&mk_file_elem => \@files], [\&mk_dir_elem => \@dirs]);

foreach my $call ($CONFIG{dirs_first} ? reverse(@calls) : @calls) {
    $generated_menu .= $call->[0]->($thisDir, $qEscapedDir, xmlEscape($_->[0]), $_->[1], $escapedProgramName)
      for sort { lc $a->[0] cmp lc $b->[0] } @{$call->[1]};
}

local $| = 1;
print $generated_menu, "</openbox_pipe_menu>";
exit;
