fbmenugen

#!/usr/bin/perl

# Copyright (C) 2010-2023 Daniel "Trizen" Șuteu <echo dHJpemVuQHByb3Rvbm1haWwuY29tCg== | 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 <https://www.gnu.org/licenses/>.

# Fluxbox Menu Generator
# A simple menu generator for the Fluxbox Window Manager
# Should be installed in $PATH before the first execution!

# Name: fbmenugen
# License: GPLv3
# Created on: 01 August 2010
# Latest edit on: 22 September 2023
# https://github.com/trizen/fbmenugen

use 5.014;
use File::Spec;
use Linux::DesktopFiles 0.25;

my $pkgname = 'fbmenugen';
my $version = '0.88';

my ($with_icons, $db_clean, $create_menu, $pipe, $reload_config, $update_config);

our ($CONFIG, $SCHEMA);

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

my $xdg_config_home = $ENV{XDG_CONFIG_HOME} || "$home_dir/.config";
my $xdg_cache_home  = $ENV{XDG_CACHE_HOME}  || "$home_dir/.cache";

my $config_dir  = "$xdg_config_home/$pkgname";
my $schema_file = "$config_dir/schema.pl";
my $config_file = "$config_dir/config.pl";
my $cache_dir   = "$xdg_cache_home/$pkgname";
my $fluxbox_dir = "$home_dir/.fluxbox";
my $menu_file   = "$fluxbox_dir/menu";
my $cache_db    = "$cache_dir/cache.db";
my $icons_dir   = "$cache_dir/icons";

sub usage {
    print <<"HELP";
usage: $0 [options]

menu:
    -g  : generate a new menu
    -i  : include icons
    -p  : pipe menu (prints to STDOUT)

misc:
    -u         : update the config file
    -d         : regenerate the cache file
    -S <file>  : absolute path to the schema.pl file
    -C <file>  : absolute path to the config.pl file
    -o <file>  : menu file (default: ~/.fluxbox/menu)

info:
    -h         : print this message and exit
    -v         : print version and exit

example:
    $0 -g -i      # generates a menu with icons

=> Config file: $config_file
=> Schema file: $schema_file
HELP
    exit 0;
}

my $config_help = <<"HELP";

|| FILTERING
    | skip_filename_re    : Skip a .desktop file if its name matches the regex.
                            Name is from the last slash to the end. (e.g.: name.desktop)
                            Example: qr/^(?:gimp|xterm)\\b/,    # skips 'gimp' and 'xterm'

    | skip_entry          : Skip a desktop file if the value from a given key matches the regex.
                            Example: [
                                {key => 'Name',       re => qr/(?:about|terminal)/i},
                                {key => 'Exec',       re => qr/^xterm/},
                                {key => 'OnlyShowIn', re => qr/XFCE/},
                            ],

    | substitutions       : Substitute, by using a regex, in the values from the desktop files.
                            Example: [
                                {key => 'Exec', re => qr/xterm/, value => 'tilix', global => 1},
                            ],

|| ICON SETTINGS
    | gtk_version         : The version of the Gtk library used for resolving the icon paths. (default: 3)
    | gtk_rc_filename     : Absolute path to the Gtk configuration file.
    | missing_icon        : Use this icon for missing icons (default: gtk-missing-image)
    | icon_size           : Preferred size for icons. (default: 32)
    | generic_fallback    : Try to shorten icon name at '-' characters before looking at inherited themes. (default: 0)
    | force_icon_size     : Always get the icon scaled to the requested size. (default: 0)

|| PATHS
    | desktop_files_paths   : Absolute paths which contain .desktop files.
                              Example: [
                                '/usr/share/applications',
                                "\$ENV{HOME}/.local/share/applications",
                                glob("\$ENV{HOME}/.local/share/applications/wine/Programs/*"),
                              ],

|| NOTES
    | Regular expressions:
        * use qr/.../ instead of '...'
        * use qr/.../i for case insensitive mode
HELP

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

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

if (@ARGV) {
    while (defined(my $arg = shift @ARGV)) {
        if ($arg eq '-i') {
            $with_icons  = 1;
            $create_menu = 1;
        }
        elsif ($arg eq '-g') {
            $create_menu = 1;
        }
        elsif ($arg eq '-p') {
            $pipe = 1;
        }
        elsif ($arg eq '-d') {
            $db_clean = 1;
            print STDERR ":: Regenerating the cache DB...\n";
            remove_database($cache_db);
        }
        elsif ($arg eq '-u') {
            $update_config = 1;
        }
        elsif ($arg eq '-v') {
            print "$pkgname $version\n";
            exit 0;
        }
        elsif ($arg eq '-o') {
            $menu_file = shift(@ARGV) // die "$0: option '-o' requires an argument!\n";
        }
        elsif ($arg eq '-S') {
            $schema_file = shift(@ARGV) // die "$0: option '-S' requires an argument!\n";
        }
        elsif ($arg eq '-C') {
            $reload_config = 1;
            $config_file   = shift(@ARGV) // die "$0: options '-C' requires an argument!\n";
        }
        elsif ($arg eq '-h') {
            usage();
        }
        else {
            die "$0: option `$arg' is invalid!\n";
        }
    }
}

if (not -d $config_dir) {
    require File::Path;
    File::Path::make_path($config_dir)
      or die "$0: can't create configuration directory `$config_dir': $!\n";
}

if (not -d $cache_dir) {
    require File::Path;
    File::Path::make_path($cache_dir)
      or die "$0: can't create cache directory `$cache_dir': $!\n";
}

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 $config_documentation = <<"EOD";
#!/usr/bin/perl

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

=for comment
$config_help
=cut

EOD

my %CONFIG = (
    'Linux::DesktopFiles' => {

        keep_unknown_categories => 1,
        unknown_category_key    => 'other',

        skip_entry       => undef,
        substitutions    => undef,
        skip_filename_re => undef,

        terminalize            => 1,
        terminalization_format => q{%s -e '%s'},

#<<<
        desktop_files_paths => [
            '/usr/share/applications',
            '/usr/local/share/applications',
            '/usr/share/applications/kde4',
            "$home_dir/.local/share/applications",
        ],
#>>>
    },

    menu_title      => 'Fluxbox',
    terminal        => 'xterm',
    editor          => 'geany',
    missing_icon    => 'gtk-missing-image',
    gtk_rc_filename => "$home_dir/.config/gtk-3.0/settings.ini",

    icon_size        => 32,
    force_icon_size  => 0,
    generic_fallback => 0,
    locale_support   => 1,
    gtk_version      => 3,

    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) {
    dump_configuration();
}

if (not -e $schema_file) {
    if (-e (my $etc_schema_file = "/etc/xdg/$pkgname/schema.pl")) {
        require File::Copy;
        File::Copy::copy($etc_schema_file, $schema_file)
          or warn "$0: can't copy file `$etc_schema_file' to `$schema_file': $!\n";
    }
    else {
        die "$0: schema file `$schema_file' does not exists!\n";
    }
}

foreach my $file (\$schema_file, \$config_file) {
    if (not File::Spec->file_name_is_absolute($$file)) {
        $$file = File::Spec->rel2abs($$file);
    }
}

# Load the configuration files
require $schema_file;
require $config_file if $reload_config;

# Remove invalid user-defined keys
my @valid_keys = grep { exists $CONFIG{$_} } keys %$CONFIG;
@CONFIG{@valid_keys} = @{$CONFIG}{@valid_keys};

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

#<<<
my @desktop_files_paths = do {
    my %seen;
    grep { !$seen{$_}++ } (
        ($ENV{XDG_DATA_DIRS} ? split(/:/, $ENV{XDG_DATA_DIRS}) : ()),
        @{$CONFIG{'Linux::DesktopFiles'}{desktop_files_paths}},
    );
};
#>>>

my $desk_obj = Linux::DesktopFiles->new(
    %{$CONFIG{'Linux::DesktopFiles'}},
    desktop_files_paths => \@desktop_files_paths,

    categories => [map { exists($_->{cat}) ? $_->{cat}[0] : () } @$SCHEMA],

    keys_to_keep => ['Name', 'Exec', 'Path',
                     ($with_icons ? 'Icon' : ()),
                     (
                      ref($CONFIG{'Linux::DesktopFiles'}{skip_entry}) eq 'ARRAY'
                      ? (map { $_->{key} } @{$CONFIG{'Linux::DesktopFiles'}{skip_entry}})
                      : ()
                     ),
                    ],

    terminal              => $CONFIG{terminal},
    case_insensitive_cats => 1,
);

my $generated_menu = <<"HEADER";
#
## Menu generated with $pkgname v$version
#

[begin] ($CONFIG{menu_title})
[encoding] {UTF-8}
HEADER

{
    my $menu_backup = $menu_file . '.bak';
    if (not -e $menu_backup and -e $menu_file) {
        require File::Copy;
        File::Copy::cp($menu_file, $menu_backup);
    }
}

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

    state $gtk = do {

        require Digest::MD5;

        ($CONFIG{gtk_version} == 3)
          ? 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'  : ()),
        ]
    );
#>>>

    foreach my $icon_name ($name, $CONFIG{missing_icon}) {

#<<<
        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 '';
}

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

eval { require GDBM_File } // eval { require DB_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 = exists($cache_db{__GTKRC_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(%cache_db, $cache_db, 0777)
              or die "Can't create database <<$cache_db>>: $!";

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

{
    my %fast_cache;

    sub check_icon {
        $fast_cache{$_[0] // return undef} //= do {
            exists($cache_db{$_[0]})
              ? $cache_db{$_[0]}
              : do { $cache_db{$_[0]} = get_icon_path($_[0]) }
        };
    }
}

sub prepare_item {
    my $command = shift() =~ s/\}/\\}/gr;
    my $name    = shift() =~ s/\)/\\)/gr;
    my $icon    = shift() || $CONFIG{missing_icon};

    if ($with_icons and (my $icon_path = check_icon($icon))) {
        return <<"ITEM_WITH_ICON";
  [exec] ($name) {$command} <$icon_path>
ITEM_WITH_ICON
    }

    <<"ITEM";
  [exec] ($name) {$command}
ITEM
}

sub begin_category {
    my ($name, $icon) = @_;

    if ($with_icons and (my $icon_path = check_icon($icon))) {
        return <<"MENU_WITH_ICON";
[submenu] ($name) <$icon_path>
MENU_WITH_ICON
    }

    <<"MENU";
[submenu] ($name)
MENU
}

my %categories;
foreach my $file ($desk_obj->get_desktop_files) {

    my %info = split("\0\1\0", (exists($cache_db{$file}) ? $cache_db{$file} : ''), -1);

    next if exists $info{__IGNORE__};

    my $mtime    = (stat $file)[9];
    my $cache_ok = (%info and $info{__MTIME__} == $mtime);

    if ($with_icons and $cache_ok and not exists $info{Icon}) {
        $cache_ok = 0;
    }

    if (not $cache_ok) {

        my $entry = $desk_obj->parse_desktop_file($file) // do {
            $cache_db{$file} = join("\0\1\0", __IGNORE__ => 1);
            next;
        };

#<<<
        %info = (
            Name => $entry->{Name} // next,
            Exec => $entry->{Exec} // next,
            Path => $entry->{Path} // '',

            (
             $with_icons
             ? (Icon => $entry->{Icon})
             : ()
            ),

            __CATEGORIES__ => join(';', @{$entry->{Categories}}),
            __MTIME__      => $mtime,
        );
#>>>

        # Support for the Path key
        if ($info{Path} ne '') {
            require Encode;
            my $path = Encode::decode_utf8($info{Path});
            my $exec = Encode::decode_utf8($info{Exec});
            $exec = "$^X -e 'chdir(\$ARGV[0]) && exec(\$ARGV[1])' \Q$path\E \Q$exec\E";
            $info{Exec} = Encode::encode_utf8($exec);
        }

        eval {

            state $x = do {
                require Encode;
                require File::DesktopEntry;
            };

            $info{Name} = Encode::encode_utf8(File::DesktopEntry->new($file)->get('Name') // '');

        } if $CONFIG{locale_support};

        $cache_db{$file} = join("\0\1\0", %info);
    }

    foreach my $category (split(/;/, $info{__CATEGORIES__})) {
        push @{$categories{$category}}, \%info;
    }
}

foreach my $schema (@$SCHEMA) {
    if (exists $schema->{cat}) {
        exists($categories{my $category = lc($schema->{cat}[0]) =~ tr/_a-z0-9/_/cr}) || next;
        $generated_menu .= begin_category($schema->{cat}[1], ($with_icons ? $schema->{cat}[2] : ()))
          . join(q{},
                 map  { $_->[1] }
                 sort { $a->[0] cmp $b->[0] }
                 map  { [lc($_), $_] }
                 map  { prepare_item($_->{Exec}, $_->{Name}, $with_icons ? $_->{Icon} : ()) } @{$categories{$category}})
          . "[end]\n";
    }
    elsif (exists $schema->{item}) {
        $generated_menu .= prepare_item(@{$schema->{item}});
    }
    elsif (exists $schema->{sep}) {
        $generated_menu .= "[separator]\n";
    }
    elsif (exists $schema->{beg}) {
        $generated_menu .= begin_category(@{$schema->{beg}});
    }
    elsif (exists $schema->{begin_cat}) {
        $generated_menu .= begin_category(@{$schema->{begin_cat}});
    }
    elsif (exists $schema->{end}) {
        $generated_menu .= "[end]\n";
    }
    elsif (exists $schema->{end_cat}) {
        $generated_menu .= "[end]\n";
    }
    elsif (exists $schema->{raw}) {
        $generated_menu .= "$schema->{raw}\n";
    }
    elsif (exists $schema->{fbmenugen}) {
        $generated_menu .= begin_category(@{$schema->{fbmenugen}});
        require Cwd;
        foreach my $item (
                          [join(' ', $CONFIG{editor}, quotemeta(Cwd::abs_path($menu_file))),   'Menu file'],
                          [join(' ', $CONFIG{editor}, quotemeta(Cwd::abs_path($config_file))), 'Config file'],
                          [join(' ', $CONFIG{editor}, quotemeta(Cwd::abs_path($schema_file))), 'Schema file'],
          ) {
            $generated_menu .= prepare_item(@$item, $schema->{fbmenugen}[1]);
        }
        $generated_menu .= "[end]\n";
    }
    elsif (exists $schema->{exit}) {
        my ($name, $icon) = @{$schema->{exit}};
        if ($with_icons and (my $icon_path = check_icon($icon))) {
            $generated_menu .= <<EXIT_WITH_ICON;
[exit] ($name) <$icon_path>
EXIT_WITH_ICON
        }
        else {
            $generated_menu .= <<EXIT;
[exit] ($name)
EXIT
        }
    }
    elsif (exists $schema->{regenerate}) {
        require Cwd;
        my $regenerate_exec = join(
                                   q{ }, $^X, quotemeta(Cwd::abs_path($0)), ($with_icons ? '-i' : ()),
                                   '-S' => quotemeta(Cwd::abs_path($schema_file)),
                                   '-C' => quotemeta(Cwd::abs_path($config_file)),
                                   '-o' => quotemeta(Cwd::abs_path($menu_file)),
                                  );

        my ($label, $icon) = @{$schema->{regenerate}};
        $generated_menu .= prepare_item($regenerate_exec, $label, $icon);
    }
    elsif (exists $schema->{fluxbox}) {
        my ($label, $icon) =
          ref $schema->{fluxbox} eq 'ARRAY'
          ? @{$schema->{fluxbox}}
          : $schema->{fluxbox};

        $generated_menu .= begin_category(@{$schema->{fluxbox}}) . <<"FOOTER";
[config] (Configure)
[submenu] (System Styles) {Choose a style...}
  [stylesdir] (/usr/share/fluxbox/styles)
[end]
[submenu] (User Styles) {Choose a style...}
  [stylesdir] (~/.fluxbox/styles)
[end]
[workspaces] (Workspace List)
[submenu] (Tools)
  [exec] (Screenshot - JPG) {import screenshot.jpg && display -resize 50% screenshot.jpg}
  [exec] (Screenshot - PNG) {import screenshot.png && display -resize 50% screenshot.png}
  [exec] (Run) {fbrun}
  [exec] (Regen Menu) {fluxbox-generate_menu}
[end]
[commanddialog] (Fluxbox Command)
  [reconfig] (Reload config)
  [restart] (Restart)
  [exec] (About) {(fluxbox -v; fluxbox -info | sed 1d) | xmessage -file - -center}
  [separator]
  [exit] (Exit)
[end]
FOOTER
    }
}

$generated_menu .= "\n[endencoding]\n[end]\n";

if ($create_menu) {

    my $out_fh = $pipe ? \*STDOUT : do {
        open my $fh, '>', $menu_file
          or die "Can't open '${menu_file}' for write: $!";
        $fh;
    };

    print $out_fh $generated_menu;

    if (!$pipe) {
        print STDERR ":: A new menu has been successfully generated!\n";
    }
}
else {
    print STDERR "[!] To generate a new menu, please specify option `-g`.\n";
}

dump_configuration() if $update_config;

dbmclose(%cache_db);