#!@PERL@ # Modification History # Changed on 11/30/10 by (dane): # - changed DIR filehandles to scalars, they're stepping on each other. # was a bug in xdg-menu. # - changed default (only) format to fvwm2 and removed logic for other wms. # - move mainline before all subs (move it back?). # - removed the xdg_menu cache logic. # - Remove $flag, $MENU_TYPE, $MENU_DESTROY for gtk vs. fvwm menu mode. # Actually removed all GTK MENU logic. # - Added option to menu to regenerate the menus. # - Remove xdg option root_menu. # - Added fvwm-menu option to use Fvwm Icons package. # - Style options from fvwmmenudesktop not carried over, # WM hints are sufficient to set mini-icon and icon. # - Removed prototypes. None were needed. # - All filehandle names made local. # - New option for su_gui, do path check for alternatives. # - Change menu prefix from xdg-menu to FvwmMenu # # FIXME: # - No testing for wm_icons has been done (is that fvwm-themes?). # - Docs need to be updated. # - fvwm-icons: okay, maybe the cat isn't a good default for Exec... # - Running alacarte, I can see there are Application menus, and System menus. # Figure out the options to get both. # - There are good programs like alacarte that are marked GNOME-ONLY. # Figure out how to get them in menus. # - I think this should default to mini-icons enabled, but which # icon package should be assumed? # - Need a way to select the /usr/share/icons icon sets with themes like # default/hicolor and size like 16x16 and 24x24. # - Regenerate menus should prompt for a new command line. # - sidepics, etc not tested. # - iconname::: syntax needs investigation, I think some of it is obsolete, # needs a verifier, and some defaults. # - Far too many lexical globals not bound to subroutines (c.f. # modularisation.) # - I don't see the point to the path arguments. I think they should # be obsoleted. # - If I pass --fvwm-icons I don't need to set --enable-mini-icons. # Therefore I think enable mini-icons is pointless. # - The "check" functions are useless. Since this module doesn't get the # built in path, or the users path, it can't do the check. # - Looks like there is no such thing as fvwm_toptitle, must have been a gtk thing? # --------------------------------------------------------------------------- # fvwm-menu-desktop # See the man page fvwm-menu-desktop.1 for instructions. # # Created on 22/07/1999 by Olivier Chapuis # # Updated on 15/08/1999 by Mikhael Goikhman # # Updated on 24/12/2010 by Dan Espen for xdg menus (see copyright below) # --------------------------------------------------------------------------- # COPYING # # The script is distributed by the same terms as fvwm itself. # See GNU General Public License for details. # #---------------------------------------------------------------------------- # 25/12/2010 re-written, based heavily on # xdg-menu for archlinux. based on suse xdg-menu written by # Sergej Pupykin # # >> Copyright (c) 2003 SuSE Linux AG, Nuernberg, Germany. All rights reserved. # >> # >> Author: nadvornik@suse.cz use version '5.0008'; use strict; use warnings; use Getopt::Long; use Encode; use I18N::Langinfo qw(langinfo CODESET); use POSIX qw(locale_h); use Digest::MD5 qw(md5_hex); use XML::Parser; my $xdg_data_dirs = $ENV{XDG_DATA_DIRS} || ''; my $xdg_config_dirs = $ENV{XDG_CONFIG_DIRS} || ''; my @PATH_DIRS = split(':',$ENV{PATH}); # for checking if applications exist my $version = '@VERSION@'; my $menu_prefix='FvwmMenu'; my $DefaultAppDirs; my $DefaultDirectoryDirs; my @KDELegacyDirs; my $desktop_name = 'fvwm2'; my $language = ''; my $charset = 'iso-8859-1'; my $root_cmd; my $die_on_error = 0; my $verbose = 0; my @language_keys; #my @accessed_files; my $TERM_CMD = "xterm -e"; my %Desktop_entries; my %Directory_entries; my $root_menu; my $help; # Default for the mini-icons is mini/ (relatively to the ImagePath) my $MINI_ICONS_DIR = 'mini/'; # Then the default for icon is ImagePath (consistent with kde, fvwm2gnome # and almost consistent with wm-icons) my $ICONS_DIR = ''; # For png icons my $PNG_ICONS = ''; my $TRAN_MINI_ICONS = 'mini/'; my $TRAN_ICONS = ''; my $MINI_ICONS = 0; # mini-icon disabled (enable =1) my $TRAN = 0; # mini-icon translation disabled (enable =1) my $wm_icons = 0; # use wm-icons compatible menu icon names my $fvwm_icons = 0; # use fvwm-icons compatible menu icon names # check icons my $check_icons = ""; my $check_mini_icons = ""; my @check_icons_path = (); my @check_mini_icons_path = (); my %DI; my %dmicon; # Menu Style option my $MENU_STYLE = ""; my @menus_for_style = (); # default for style $DI{fvwm_app} = 'mini-x.xpm:dh:%::'; # micon:law:placement:unused $DI{fvwm_folder} = 'folder.xpm:dh:%::'; # idem $DI{fvwm_title} = 'folder.xpm:dh:%::'; # micon:law:place:spic:color $DI{fvwm_toptitle} = 'mini-k.xpm:no:%::'; # idem my $OPT_INSTALL_PREFIX = ''; warn "invoked with args @ARGV\n" if $verbose; GetOptions( "enable-mini-icons" => \$MINI_ICONS, "enable-tran-mini-icons" => \$TRAN, "mini-icons-path:s" => \$MINI_ICONS_DIR, "png-icons-path:s" => \$PNG_ICONS, "tran-mini-icons-path:s" => \$TRAN_MINI_ICONS, "icon-toptitle:s" => \$DI{"fvwm_toptitle"}, "icon-title:s" => \$DI{"fvwm_title"}, "icon-folder:s" => \$DI{"fvwm_folder"}, "icon-app:s" => \$DI{"fvwm_app"}, "icon-style:s" => \&obsolete, "icons-path:s" => \$ICONS_DIR, "tran-icons-path:s" => \$TRAN_ICONS, "wm-icons" => \$wm_icons, "fvwm-icons" => \$fvwm_icons, "check-mini-icon=s" => \$check_mini_icons, "check-icons=s" => \$check_icons, "help|h|?" => \&show_help, "version|V" => \&show_version, "install-prefix:s" => $OPT_INSTALL_PREFIX, "type:s" => \&obsolete, "fvwmgtk-alias=s" => \&obsolete, "title:s" => \&obsolete, "name:s" => \&obsolete, "enable-style" => \&obsolete, "enable-tran-style" => \&obsolete, "submenu-name-prefix:s" => \&obsolete, "dir:s" => \&obsolete, "destroy-type:s" => \&obsolete, "xterm:s" => \$TERM_CMD, "lang:s" => \$language, "utf8" => \&obsolete, "uniconv=s" => \$charset, "uniconv-exec=s" => \&obsolete, "menu-style=s" => \$MENU_STYLE, "check-app!" => \&obsolete, "time-limit=s" => \&obsolete, "merge-user-menu" => \&obsolete, "su_gui" => \$root_cmd, "verbose" => \$verbose ); icon_init(); $DefaultAppDirs = get_app_dirs(); $DefaultDirectoryDirs = get_desktop_dirs(); $root_menu = get_root_menu(); @KDELegacyDirs = get_KDE_legacy_dirs(); $charset = langinfo(CODESET); $language = setlocale(LC_MESSAGES); if (! defined $root_cmd ) { foreach (qw(gnomesu kdesu xdg_menu_su)) { if (check_app($_)) { $root_cmd = $_; last; } } } if ($verbose) { warn qq| DEBUG: root menu is $root_menu DEBUG: charset is $charset. DEBUG: language is $language. DEBUG: root-cmd is $root_cmd.|; } @language_keys = prepare_language_keys($language); unless (-f $root_menu) { warn "ERROR: Can't find root menu file.\n"; exit 1; } my $tree = read_menu($root_menu); merge_menus($tree); move_menus($tree); my $menu = interpret_root($tree, ''); remove_allocated($menu); preprocess_menu($menu); remove_empty_menus($menu); my $output = output_fvwm2_menu($menu); print $output; # output the menu style if ($MENU_STYLE ne "") { foreach (@menus_for_style) { print qq|ChangeMenuStyle "$MENU_STYLE" "$_"\n|; } } exit 0; # Set DI to list of icons to use: sub icon_init { my @list=(); my %law; my %place; my %spic; my %scolor; my $j = ""; my $l = ""; my $tmp_icon =""; if ($wm_icons) { $MINI_ICONS = 1; $MINI_ICONS_DIR = ""; $DI{"fvwm_toptitle"} = "menu/folder-open.xpm:ow"; $DI{"fvwm_title"} = "menu/folder-open.xpm:ow"; $DI{"fvwm_folder"} = "menu/folder.xpm:ow"; $DI{"fvwm_app"} = "menu/utility.xpm:ow"; } if ($fvwm_icons) { $MINI_ICONS = 1; $MINI_ICONS_DIR = ""; $DI{"fvwm_toptitle"} = "mini.fvwm.xpm::%"; $DI{"fvwm_title"} = "mini.folder.xpm::%"; $DI{"fvwm_folder"} = "mini.ofolder.xpm::%"; $DI{"fvwm_app"} = "mini.cat.xpm::%"; } foreach my $i (keys(%DI)) { @list = split(':',$DI{$i}); $dmicon{$i} = $list[0]; # "default" mini-icon $law{$i} = $list[1]; # default law $place{$i} = $list[2]; # default position $spic{$i} = $list[3]; # sidepic icon $scolor{$i} = $list[4]; # color for sidepic $DI{$i} = ''; } if ($TRAN) { $MINI_ICONS = 1; } if ($MINI_ICONS_DIR ne 'mini/' or $ICONS_DIR ne '') { if ($MINI_ICONS_DIR ne '') { $MINI_ICONS_DIR =~ s/\/*$/\//; } if ($ICONS_DIR eq '') { $ICONS_DIR = up_directory($MINI_ICONS_DIR); } elsif ($ICONS_DIR eq 'inpath') { $ICONS_DIR = ''; } else { $ICONS_DIR =~ s/\/*$/\// if $MINI_ICONS_DIR ne ''; } } if ($TRAN_MINI_ICONS ne 'mini/' or $TRAN_ICONS ne '') { if ($TRAN_MINI_ICONS ne '') { $TRAN_MINI_ICONS =~ s/\/*$/\//; } if ($TRAN_ICONS eq '') { $TRAN_ICONS = up_directory($TRAN_MINI_ICONS); } elsif ($TRAN_ICONS eq 'inpath') { $TRAN_ICONS = ''; } else { $TRAN_ICONS =~ s/\/*$/\// if $TRAN_ICONS ne ''; } } $PNG_ICONS =~ s/\/*$/\// if $PNG_ICONS ne ''; # init default mini-icons, law, place, sidepic, color foreach my $i (qw(fvwm_app fvwm_folder fvwm_title fvwm_toptitle)) { warn "DEBUG: foreach $i.\n" if $verbose; # dje debug # With the mini-icons-tran options we "use" gtk default if ($TRAN) { $j = substr($i,index($i,'_')); $j = "gtk$j"; $law{$i} = $law{$j}; $tmp_icon = $dmicon{$j}; $tmp_icon =~ s/\.png$/\.xpm/; $dmicon{$i} = "$TRAN_MINI_ICONS$tmp_icon"; } else { $dmicon{$i} = "$MINI_ICONS_DIR$dmicon{$i}"; } if ($verbose) { while (my ($key,$value) = each %dmicon) { warn "INTERMEDIATE icons to use $key -> $value.\n"; } } @list = split(':',$DI{$i}); $l = @list; while ($l <= 5) { push(@list,''); ++$l; } $law{$i} = $list[1] if ($list[1] eq 'no' or $list[1] eq 'ow' or $list[1] eq 're' or $list[1] eq 'dh'); $dmicon{$i} = "$MINI_ICONS_DIR$list[0]" if $list[0] ne ''; $place{$i} = '*' if $list[2] eq 'up'; $dmicon{$i} = "$place{$i}$dmicon{$i}$place{$i}"; $dmicon{$i} = '' if $law{$i} eq 'no' or $MINI_ICONS == 0; if ($list[3] ne '') { $spic{$i} = "\@$list[3]\@"; } else { $spic{$i} = ''; } if ($list[4] ne '' and $list[3] ne '') { $scolor{$i} = "\^$list[4]\^"; } else { $scolor{$i} = ''; } if ($check_mini_icons ne "") { @check_mini_icons_path = split(":", $check_mini_icons); } if ($check_icons ne "") { @check_icons_path = split(":", $check_icons); } if ($verbose) { while (my ($key, $value) = each %dmicon) { warn "icons to use $key -> $value.\n"; } } } } # Compute cd .. sub up_directory { my($dir) = @_; if ($dir eq '') { return '../'; } chop($dir); if ($dir !~ /\//) { return ''; } $dir = substr($dir, 0, rindex($dir, '/') + 1); return $dir; } sub check_file { my ($file) = @_; unless (-e $file) { return ''; } if (-d $file) { return 'D'; } return 'F'; } sub scan_AppDir { my ($pool, $dir, $topdir) = @_; check_file($dir); $topdir = $dir unless defined $topdir; return if check_file($dir) ne 'D'; opendir( my $dir_fh, $dir ) or return; foreach my $entry ( readdir($dir_fh) ) { if (-f "$dir/$entry" and $entry =~ /\.desktop$/) { read_desktop_entry($pool, "$dir/$entry", $topdir); } elsif (-d "$dir/$entry" and $entry !~ /^\.{1,2}$/ and $entry ne '.hidden') { scan_AppDir($pool, "$dir/$entry", $topdir); } } closedir $dir_fh; } sub scan_DirectoryDir { my ($pool, $dir, $topdir) = @_; check_file($dir); $topdir = $dir unless defined $topdir; opendir( my $dir_fh, $dir ) or return; foreach my $entry (readdir($dir_fh)) { if (-f "$dir/$entry" and $entry =~ /\.directory$/) { read_directory_entry( $pool, "$dir/$entry", $topdir ); } elsif (-d "$dir/$entry" and $entry !~ /^\.{1,2}$/ and $entry ne '.hidden') { scan_DirectoryDir($pool, "$dir/$entry", $topdir); } } closedir $dir_fh; } sub read_directory_entry { my ($pool, $file, $topdir) = @_; unless (defined $Directory_entries{$file}) { check_file($file); if ($verbose) { warn "Read directory entry, opening file $file.\n"; } open( my $file_fh, "<", $file ) or return; my $in_desktop_entry = 0; my %entry; while (<$file_fh>) { if (/^\[/) { if (/^\[Desktop Entry\]/) { $in_desktop_entry = 1; } elsif (/^\[.*\]/) { $in_desktop_entry = 0; } } elsif ($in_desktop_entry and /^([^=]*)=([^[:cntrl:]]*)/) { $entry{$1} = $2; } } close($file_fh); my $id = $file; $id =~ s/^$topdir//; $id =~ s/^\/*//; $id =~ s/\//-/g; $entry{'id'} = $id; $Directory_entries{$file} = \%entry; } my $entry = $Directory_entries{$file}; $pool->{'Directory_entries'}{ $entry->{'id'} } = $entry; } sub check_show_in { my ($entry) = @_; return 1 unless defined $entry; my (%OnlyShowIn, %NotShowIn); if (defined $entry->{'OnlyShowIn'}) { foreach my $showin (split /;/, $entry->{'OnlyShowIn'}) { $OnlyShowIn{$showin} = 1; } return 0 unless defined $OnlyShowIn{$desktop_name}; } if (defined $entry->{'NotShowIn'}) { foreach my $showin (split /;/, $entry->{'NotShowIn'}) { $NotShowIn{$showin} = 1; } return 0 if defined $NotShowIn{$desktop_name}; } return 1; } sub read_desktop_entry { my ($pool, $file, $topdir) = @_; unless (defined $Desktop_entries{$file}) { check_file($file); if ($verbose) { warn "Read desktop entry, opening file $file.\n"; } open( my $file_fh, "<", $file ) or return; my $in_desktop_entry = 0; my %entry; while (<$file_fh>) { if (/^\[/) { if (/^\[Desktop Entry\]/) { $in_desktop_entry = 1; } elsif (/^\[.*\]/) { $in_desktop_entry = 0; } } elsif ($in_desktop_entry && /^([^=]*)=([^[:cntrl:]]*)/) { $entry{$1} = $2; } } close($file_fh); my $id = $file; $id =~ s/^$topdir//; $id =~ s/^\/*//; $id =~ s/\//-/g; $entry{'id'} = $id; $entry{'refcount'} = 0; $Desktop_entries{$file} = \%entry; } my $entry = $Desktop_entries{$file}; if (! defined $entry->{'Name'}) { # dje debug warn "Name is not defined\n"; } return unless defined $entry->{'Name'}; return unless defined $entry->{'Exec'}; if (defined $entry->{'Hidden'} and $entry->{'Hidden'} eq 'true') { return; } #FIXME, an option for this would be good if (defined $entry->{'NoDisplay'} and $entry->{'NoDisplay'} eq 'true') { return; } return unless check_show_in($entry); if (defined $entry->{'NotShowIn'} and $entry->{'NotShowIn'} eq $desktop_name) { return; } if (defined $pool and defined $entry->{'Categories'}) { foreach my $category (split /;/, $entry->{'Categories'}) { $pool->{'Categories'}{$category} = [] unless defined $pool->{'Categories'}{$category}; push @{ $pool->{'Categories'}{$category} }, $entry; } $pool->{'Desktop_entries'}{ $entry->{'id'} } = $entry; } return $entry; } sub read_desktop_entries { my ($directory_paths, $desktop_paths) = @_; my $pool = { 'Desktop_entries' => {}, 'Categories' => {}, 'Directory_entries' => {}, 'Directory_paths' => $directory_paths, 'Desktop_paths' => $desktop_paths }; foreach my $dir (split /:/, $directory_paths) { next if $dir =~ /^\s*$/; scan_DirectoryDir( $pool, $dir ); } foreach my $dir (split /:/, $desktop_paths) { next if $dir =~ /^\s*$/; scan_AppDir( $pool, $dir ); } return $pool; } sub get_directory_entry { my ($entry, $pool) = @_; return $pool->{'Directory_entries'}{$entry}; } sub interpret_Include { my ( $tree, $entries, $pool ) = @_; my %exist; my @list = interpret_entry_node( $tree, 'Or', $pool ); foreach my $e (@$entries) { if ( $e->{type} eq 'desktop' ) { $exist{ $e->{desktop} } = 1; } } foreach my $entry (@list) { next if $exist{$entry}; push @$entries, { type => 'desktop', desktop => $entry }; $entry->{'refcount'}++; $exist{$entry} = 1; } } sub interpret_Exclude { my ( $tree, $entries, $pool ) = @_; my @list = interpret_entry_node( $tree, 'Or', $pool ); foreach my $entry (@list) { my $i = 0; while ( defined $entries->[$i] ) { my $exist = $entries->[$i]; if ($exist->{type} eq 'desktop' and $exist->{desktop} eq $entry ) { splice @$entries, $i, 1; $entry->{'refcount'}--; } else { $i++; } } } } sub interpret_entry_node { my ( $tree, $node, $pool ) = @_; my $i = 0; $i++ if ( ref( $tree->[$i] ) eq 'HASH' ); my @subtree; while (defined $tree->[$i]) { if ($tree->[$i] eq 'Filename') { $i++; if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0') { my $entry = $tree->[$i][2]; if (defined $pool->{'Desktop_entries'}{$entry}) { push @subtree, [ $pool->{'Desktop_entries'}{$entry} ]; } else { push @subtree, []; } } else { warn "Filename\n"; exit 1 if $die_on_error; } $i++; } elsif ($tree->[$i] eq 'Category') { $i++; if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0') { my $category = $tree->[$i][2]; if (defined $pool->{'Categories'}{$category}) { push @subtree, $pool->{'Categories'}{$category}; } else { push @subtree, []; } } else { warn "Category\n"; exit 1 if $die_on_error; } $i++; } elsif ($tree->[$i] eq 'All') { $i++; if (values %{ $pool->{'Desktop_entries'} } > 0) { push @subtree, [ values %{ $pool->{'Desktop_entries'} } ]; } else { push @subtree, []; } $i++; } elsif ($tree->[$i] eq '0') { $i++; $i++; } else { my @res = interpret_entry_node( $tree->[ $i + 1 ], $tree->[$i], $pool ); push @subtree, \@res; $i++; $i++; } } if ($node eq 'Or') { my %used; my @res; foreach my $st (@subtree) { foreach my $entry (@$st) { if (!defined $used{$entry}) { push @res, $entry; $used{$entry} = 1; } } } return @res; } elsif ($node eq 'And') { my %used; my @res; my $cnt = @subtree; my $min = @{ $subtree[0] }; my $min_idx = 0; my $idx = 0; foreach my $st (@subtree) { my $num = @$st; if ($num < $min) { $min = $num; $min_idx = $idx; } my %dupes; foreach my $entry (@$st) { next if $dupes{$entry}; $dupes{$entry} = 1; if (!defined $used{$entry}) { $used{$entry} = 1; } else { $used{$entry}++; } } $idx++; } return () if $cnt == 0; foreach my $entry (@{ $subtree[$min_idx] }) { push @res, $entry if $used{$entry} == $cnt; } return @res; } elsif ($node eq 'Not') { my %used; my @res; my $cnt = @subtree; foreach my $st (@subtree) { foreach my $entry (@$st) { $used{$entry} = 1; } } return if $cnt == 0; foreach my $entry (values %{ $pool->{'Desktop_entries'} }) { push @res, $entry if !defined $used{$entry}; } return @res; } else { warn "Can't use '$node' inside or \n"; exit 1 if $die_on_error; return (); } } sub interpret_root { my ($tree, $topdir) = @_; if ($tree->[0] eq 'Menu') { return interpret_menu( $tree->[1] ); } else { warn "No toplevel Menu\n"; exit 1 if $die_on_error; return; } } sub interpret_menu { my ($tree, $directory_paths, $desktop_paths) = @_; $directory_paths = '' unless defined $directory_paths; $desktop_paths = '' unless defined $desktop_paths; my %menu = ( 'entries' => [], 'OnlyUnallocated' => 0, 'DontShowIfEmpty' => 0, 'Deleted' => 0 ); my $i = 0; $i++ if ref $tree->[$i] eq 'HASH'; while (defined $tree->[$i]) { if ($tree->[$i] eq 'AppDir') { if (ref( $tree->[ $i + 1 ][0] ) eq 'HASH' and $tree->[ $i + 1 ][1] eq '0') { $desktop_paths .= ':' . $tree->[ $i + 1 ][2]; splice @$tree, $i, 2; } else { warn "wrong AppDir\n"; exit 1 if $die_on_error; $i++; $i++; } } elsif ($tree->[$i] eq 'DefaultAppDirs') { $desktop_paths .= ':' . $DefaultAppDirs; splice @$tree, $i, 2; } elsif ($tree->[$i] eq 'DirectoryDir') { if (ref( $tree->[ $i + 1 ][0]) eq 'HASH' and $tree->[ $i + 1 ][1] eq '0') { $directory_paths .= ':' . $tree->[ $i + 1 ][2]; splice @$tree, $i, 2; } else { warn "wrong DirectoryDir\n"; exit 1 if $die_on_error; $i++; $i++; } } elsif ($tree->[$i] eq 'DefaultDirectoryDirs') { $directory_paths .= ':' . $DefaultDirectoryDirs; splice @$tree, $i, 2; } else { $i++; $i++; } } $menu{directory_paths} = $directory_paths; $menu{desktop_paths} = $desktop_paths; my $pool = read_desktop_entries( $directory_paths, $desktop_paths ); $i = 0; $i++ if ref $tree->[$i] eq 'HASH'; while (defined $tree->[$i]) { if ($tree->[$i] eq 'Menu') { $i++; my $submenu = interpret_menu( $tree->[$i], $directory_paths, $desktop_paths ); push( @{ $menu{'entries'} }, { type => 'menu', menu => $submenu } ); $i++; } elsif ($tree->[$i] eq 'Name') { $i++; if (ref($tree->[$i][0]) eq 'HASH' and $tree->[$i][1] eq '0') { $menu{'Name'} = $tree->[$i][2]; exit 1 if $die_on_error; } $i++; } elsif ($tree->[$i] eq 'Directory') { $i++; if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0') { $menu{'Directory'} = get_directory_entry( $tree->[$i][2], $pool ); } else { warn "wrong Directory\n"; exit 1 if $die_on_error; } $i++; } elsif ($tree->[$i] eq 'OnlyUnallocated') { $menu{'OnlyUnallocated'} = 1; $i++; $i++; } elsif ($tree->[$i] eq 'DontShowIfEmpty') { $menu{'DontShowIfEmpty'} = 1; $i++; $i++; } elsif ($tree->[$i] eq 'Deleted') { $menu{'Deleted'} = 1; $i++; $i++; } elsif ($tree->[$i] eq 'NotDeleted') { $menu{'Deleted'} = 0; $i++; $i++; } elsif ($tree->[$i] eq 'Include') { $i++; interpret_Include($tree->[$i], $menu{'entries'}, $pool); $i++; } elsif ($tree->[$i] eq 'Exclude') { $i++; interpret_Exclude($tree->[$i], $menu{'entries'}, $pool); $i++; } elsif ($tree->[$i] eq '0') { $i++; if ($tree->[$i] !~ /^\s*$/) { print STDERR "skip '$tree->[$i]'\n"; exit 1 if $die_on_error; } $i++; } else { warn "Unknown '$tree->[$i]':\n"; $i++; warn " '@{$tree->[$i]}'\n"; $i++; exit 1 if $die_on_error; } } return \%menu; } sub read_menu { my ($file, $basedir) = @_; if ($file !~ /^\// and defined $basedir) { $file = "$basedir/$file"; } unless (defined $basedir) { $basedir = $file; $basedir =~ s/\/[^\/]*$//; } unless (check_file($file)) { warn "WARNING: '$file' does not exist\n"; return [ 'Menu', [ {} ] ]; } warn "reading '$file'\n" if $verbose; my $parser = XML::Parser->new(Style => 'Tree'); my $tree = $parser->parsefile($file); my $DefaultMergeDir = $file; $DefaultMergeDir =~ s/^.*\///; $DefaultMergeDir =~ s/\.menu$/-merged/; read_includes($tree, $basedir, $DefaultMergeDir); return $tree; } sub read_menu_dir { my ($dir, $basedir) = @_; my @out; if ($dir !~ /^\// and defined $basedir) { $dir = "$basedir/$dir"; } if (check_file($dir) ne 'D') { return []; } opendir( my $dir_fh, $dir ); foreach my $entry (readdir($dir_fh)) { if (-f "$dir/$entry" and $entry =~ /\.menu$/) { my $menu = read_menu("$dir/$entry"); $menu = remove_toplevel_Menu($menu); push @out, @$menu; } } closedir $dir_fh; return \@out; } sub quote_xml { my ($txt) = @_; $txt =~ s/&/&/g; $txt =~ s//>/g; return $txt; } sub read_legacy_dir { my ($dir, $basedir) = @_; my $out; $dir =~ s/\/*$//; $basedir = $dir unless defined $basedir; return "" if check_file($dir) ne 'D'; $out = "\n"; if ($dir eq $basedir) { my $xmldir = quote_xml($dir); $out .= "$xmldir\n"; $out .= "$xmldir\n"; } else { my $name = $dir; $name =~ s/\/*$//; $name =~ s/^.*\///; $name = quote_xml($name); $out .= "$name\n"; } if (-f "$dir/.directory") { my $dir_id = "$dir/.directory"; $dir_id =~ s/^$basedir//; $dir_id =~ s/^\///; $dir_id = quote_xml($dir_id); $out .= "$dir_id\n"; } if (opendir(my $dir_fh, $dir)) { foreach my $entry (readdir($dir_fh)) { if (-f "$dir/$entry" and $entry =~ /\.desktop$/) { my $id = "$dir/$entry"; $id =~ s/^$basedir//; $id =~ s/^\///; $id =~ s/\//-/g; $id = quote_xml($id); my $desktop = read_desktop_entry( undef, "$dir/$entry", $basedir ); $out .= "$id\n" unless defined $desktop->{'Categories'}; } elsif (-d "$dir/$entry" and $entry !~ /^\.{1,2}$/ and $entry ne '.hidden') { $out .= read_legacy_dir( "$dir/$entry", $basedir ); } } closedir $dir_fh; } $out .= "\n"; return $out; } sub remove_toplevel_Menu { my ($tree) = @_; if ($tree->[0] eq 'Menu') { shift @{ $tree->[1] } if ref $tree->[1][0] eq 'HASH'; return $tree->[1]; } else { warn "No toplevel Menu\n"; exit 1 if $die_on_error; return; } } sub read_includes { my ($tree, $basedir, $DefaultMergeDir) = @_; my $i = 0; $i++ if ref $tree->[$i] eq 'HASH'; while (defined $tree->[$i]) { if ($tree->[$i] eq 'MergeFile') { if (ref( $tree->[ $i + 1 ][0]) eq 'HASH' and $tree->[ $i + 1 ][1] eq '0') { my $add_tree = read_menu( $tree->[ $i + 1 ][2], $basedir ); $add_tree = remove_toplevel_Menu($add_tree); splice @$tree, $i, 2, @$add_tree; } else { warn "wrong MergeFile\n"; exit 1 if $die_on_error; $i++; $i++; } } elsif ($tree->[$i] eq 'MergeDir') { if (ref( $tree->[ $i + 1 ][0] ) eq 'HASH' and $tree->[ $i + 1 ][1] eq '0') { my $add_tree = read_menu_dir( $tree->[ $i + 1 ][2], $basedir ); splice @$tree, $i, 2, @$add_tree; } else { warn "wrong MergeFile\n"; exit 1 if $die_on_error; $i++; $i++; } } elsif ($tree->[$i] eq 'DefaultMergeDirs') { my $add_tree = read_menu_dir( $DefaultMergeDir, $basedir ); splice @$tree, $i, 2, @$add_tree; } elsif ($tree->[$i] eq 'LegacyDir') { if (ref( $tree->[ $i + 1 ][0] ) eq 'HASH' and $tree->[ $i + 1 ][1] eq '0') { if (-d $tree->[ $i + 1 ][2]) { my $xml = read_legacy_dir( $tree->[ $i + 1 ][2] ); warn "reading legacy directory '" . $tree->[ $i + 1 ][2] . "'\n" if $verbose; my $parser = XML::Parser->new(Style => 'Tree'); my $add_tree = $parser->parse($xml); $add_tree = remove_toplevel_Menu($add_tree); splice @$tree, $i, 2, @$add_tree; } else { warn "legacy directory '" . $tree->[ $i + 1 ][2] . "' not found\n" if $verbose; splice @$tree, $i, 2, (); } } else { warn "wrong LegacyDir\n"; exit 1 if $die_on_error; $i++; $i++; } } elsif ($tree->[$i] eq 'KDELegacyDirs') { my @out; foreach my $dir (@KDELegacyDirs) { my $xml = read_legacy_dir($dir); warn "reading legacy directory '$dir'\n" if $verbose; my $parser = new XML::Parser( Style => 'Tree' ); my $add_tree = $parser->parse($xml); $add_tree = remove_toplevel_Menu($add_tree); push @out, @$add_tree; } splice @$tree, $i, 2, @out; } elsif ($tree->[$i] eq 'Menu') { $i++; read_includes( $tree->[$i], $basedir, $DefaultMergeDir ); $i++; } else { $i++; $i++; } } } sub get_menu_name { my ($tree) = @_; my $name; my $i = 0; $i++ if ref $tree->[$i] eq 'HASH'; while (defined $tree->[$i]) { if ($tree->[$i] eq 'Name') { $i++; if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0') { $name = $tree->[$i][2]; last; } else { warn "wrong Name\n"; } $i++; } else { $i++; $i++; } } unless (defined $name) { warn "Menu has no name element\n"; } return $name; } sub append_menu { my ($target, $source) = @_; my $i = 0; $i++ if ref $source->[$i] eq 'HASH'; while (defined $source->[$i]) { if ($source->[$i] ne 'Name') { push @$target, $source->[$i]; push @$target, $source->[ $i + 1 ]; } $i++; $i++; } } sub merge_menus { my ($tree) = @_; my %used; #menu name already used my $i = 0; $i++ if ref $tree->[$i] eq 'HASH'; while (defined $tree->[$i]) { if ($tree->[$i] eq 'Menu') { my $name = get_menu_name($tree->[ $i + 1 ]); if (defined $used{$name}) { my $target = $used{$name}; append_menu($tree->[$target], $tree->[ $i + 1 ]); splice @$tree, $i, 2; } else { # first appearance $used{$name} = $i + 1; $i++; $i++; } } else { $i++; $i++; } } $i = 0; $i++ if ref $tree->[$i] eq 'HASH'; while (defined $tree->[$i]) { if ($tree->[$i] eq 'Menu') { merge_menus($tree->[ $i + 1 ]); } $i++; $i++; } } sub read_Move { my ( $tree, $hash ) = @_; my $i = 0; my $old = ''; $i++ if ref $tree->[$i] eq 'HASH'; while (defined $tree->[$i]) { if ($tree->[$i] eq 'Old') { $i++; if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0') { $old = $tree->[$i][2]; } else { warn "wrong Old\n"; exit 1 if $die_on_error; } $i++; } if ($tree->[$i] eq 'New') { $i++; if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0') { $hash->{$old} = $tree->[$i][2]; } else { warn "wrong New\n"; exit 1 if $die_on_error; } $i++; } else { $i++; $i++; } } } sub find_menu_in_tree { my ( $path, $tree ) = @_; my $root = $path; $root =~ s/\/.*$//; my $subpath = $path; $subpath =~ s/^[^\/]*\/*//; my $i = 0; $i++ if ref $tree->[$i] eq 'HASH'; while (defined $tree->[$i]) { if ($tree->[$i] eq 'Menu') { if ($root eq get_menu_name( $tree->[ $i + 1 ])) { if ($subpath eq '') { return { 'parent' => $tree, 'index' => $i, 'menu' => $tree->[ $i + 1 ] }; } return find_menu_in_tree( $subpath, $tree->[ $i + 1 ] ); } } $i++; $i++; } #FIXME - TA: Don't return undef here, it's bad. return undef; } sub copy_menu { my ($path, $tree) = @_; my $tail; my $child; foreach my $elem (reverse split( /\//, $path)) { next if $elem eq ''; my $menu = [ {}, 'Name', [ {}, 0, $elem ] ]; push @$menu, ( 'Menu', $child ) if defined $child; $tail = $menu unless defined $tail; $child = $menu; } append_menu( $tail, $tree ); return $child; } sub move_menus { my ($tree) = @_; my %move; my $i = 0; $i++ if ref $tree->[$i] eq 'HASH'; while (defined $tree->[$i]) { if ($tree->[$i] eq 'Move') { read_Move($tree->[ $i + 1 ], \%move); splice @$tree, $i, 2; } else { $i++; $i++; } } foreach my $source (keys %move) { my $sourceinfo = find_menu_in_tree($source, $tree); if (defined $sourceinfo) { my $target = copy_menu($move{$source}, $sourceinfo->{'menu'}); splice @{ $sourceinfo->{'parent'} }, $sourceinfo->{'index'}, 2; push @$tree, ('Menu', $target); merge_menus($tree); } } $i = 0; $i++ if ref $tree->[$i] eq 'HASH'; while (defined $tree->[$i]) { if ($tree->[$i] eq 'Menu') { move_menus($tree->[ $i + 1 ]); } $i++; $i++; } } sub remove_allocated { my ($menu) = @_; my $i = 0; while ($i < @{ $menu->{'entries'} }) { my $entry = $menu->{'entries'}[$i]; if ($entry->{type} eq 'menu') { remove_allocated( $entry->{menu} ); $i++; } elsif ($entry->{type} eq 'desktop' and $menu->{'OnlyUnallocated'} and $entry->{desktop}{'refcount'} > 1) { $entry->{desktop}{'refcount'}--; splice @{ $menu->{'entries'} }, $i, 1; } else { $i++; } } return 0; } sub remove_empty_menus { my ($menu) = @_; my $i = 0; while ($i < @{ $menu->{'entries'} }) { my $entry = $menu->{'entries'}[$i]; if ($entry->{type} eq 'menu' and remove_empty_menus($entry->{menu})) { splice @{ $menu->{'entries'} }, $i, 1; } else { $i++; } } @{ $menu->{'entries'} } == 0 ? return 1 : return 0; } sub prepare_exec { my ( $exec, $desktop ) = @_; # Take out filename flags, etc. $exec =~ s/%f//g; $exec =~ s/%F//g; $exec =~ s/%u//g; $exec =~ s/%U//g; $exec =~ s/%d//g; $exec =~ s/%D//g; $exec =~ s/%n//g; $exec =~ s/%N//g; $exec =~ s/%i//g; $exec =~ s/%k//g; $exec =~ s/%v//g; $exec =~ s/%m//g; my $caption = $desktop->{Name}; $exec =~ s/%c/$caption/g; $exec =~ s/%%/%/g; if (defined $desktop->{Terminal}) { if ($desktop->{Terminal} eq '1' or $desktop->{Terminal} eq 'true') { $exec = "$TERM_CMD $exec"; } } if (defined $desktop->{'X-KDE-SubstituteUID'}) { if ($desktop->{'X-KDE-SubstituteUID'} eq '1' or $desktop->{'X-KDE-SubstituteUID'} eq 'true') { $exec = "$root_cmd $exec" } } return $exec; } sub get_loc_entry { my ( $desktop, $entry ) = @_; foreach my $key (@language_keys) { my $loc_entry = $entry . "[$key]"; if (defined $desktop->{$loc_entry} and $desktop->{$loc_entry} !~ /^\s*$/) { return $desktop->{$loc_entry}; } } return $desktop->{$entry}; } sub preprocess_menu { # localize, sort, prepare_exec my ($menu) = @_; return 0 if $menu->{'Deleted'}; return 0 unless check_show_in( $menu->{'Directory'} ); if( defined $menu->{'Directory'} and defined $menu->{'Directory'}->{'NoDisplay'} and $menu->{'Directory'}->{'NoDisplay'} eq 'true') { return 0; } my $menu_name = $menu->{'Name'}; if (defined $menu->{'Directory'}) { my $directory = $menu->{'Directory'}; my $directory_name = get_loc_entry( $directory, 'Name' ); if (defined $directory_name) { if( !defined $directory->{"Encoding"} or $directory->{"Encoding"} eq 'UTF-8') { Encode::from_to($directory_name, "utf8", $charset); } $menu_name = $directory_name; } } $menu->{'PrepName'} = $menu_name; my $i = 0; while ( defined $menu->{'entries'}[$i] ) { my $entry = $menu->{'entries'}[$i]; if ( $entry->{'type'} eq 'desktop' ) { my $desktop = $entry->{desktop}; my $name = $desktop->{'id'}; my $desktop_name = get_loc_entry( $desktop, 'Name' ); if ( defined $desktop_name ) { Encode::from_to( $desktop_name, "utf8", $charset ) if !defined $desktop->{"Encoding"} || $desktop->{"Encoding"} eq 'UTF-8'; $name = $desktop_name; } $desktop->{'PrepName'} = $name; $entry->{'Name'} = $name; $entry->{'PrepName'} = $name; $desktop->{'PrepExec'} = prepare_exec( $desktop->{Exec}, $desktop ); $i++; } elsif ( $entry->{type} eq 'menu' ) { if ( preprocess_menu( $entry->{'menu'} ) ) { $entry->{'Name'} = $entry->{'menu'}{'Name'}; $entry->{'PrepName'} = $entry->{'menu'}{'PrepName'}; $i++; } else { splice @{ $menu->{'entries'} }, $i, 1; } } else { warn "wrong menu entry type: $entry->{type}"; exit 1 if $die_on_error; splice @{ $menu->{'entries'} }, $i, 1; } } $menu->{'entries'} = [ sort { $b->{'type'} cmp $a->{'type'} || $a->{'PrepName'} cmp $b->{'PrepName'} } @{ $menu->{'entries'} } ]; $i = 0; my $prev_entry; while ( defined $menu->{'entries'}[$i] ) { my $entry = $menu->{'entries'}[$i]; if (defined $prev_entry and $entry->{'type'} eq 'desktop' and $prev_entry->{'type'} eq 'desktop' and $prev_entry->{'PrepName'} eq $entry->{'PrepName'} and $prev_entry->{'desktop'}->{'PrepExec'} eq $entry->{'desktop'}->{'PrepExec'} ) { splice @{ $menu->{'entries'} }, $i, 1; } else { $prev_entry = $entry; $i++; } } return 1; } sub output_fvwm2_menu { my ($menu, $toplevel, $path) = @_; $path = '' unless defined $path; $toplevel = 1 unless defined $toplevel; my $output = ''; my $label = ''; my $menu_name = $menu->{'PrepName'}; my $menu_id = "$path-" . $menu->{'Name'}; $menu_id =~ s/\s/_/g; $menu_id = $menu_prefix if $toplevel; foreach my $entry ( @{ $menu->{'entries'} } ) { if ( $entry->{type} eq 'menu' ) { $output .= output_fvwm2_menu( $entry->{'menu'}, 0, $menu_id ); } } $output .= "DestroyMenu \"$menu_id\"\n"; $output .= "AddToMenu \"$menu_id\" \"$dmicon{'fvwm_title'}$label$menu_name\" Title\n"; if ($MENU_STYLE ne '') { push @menus_for_style, $menu_id; } foreach my $entry ( @{ $menu->{'entries'} } ) { if ( $entry->{type} eq 'desktop' ) { my $desktop = $entry->{desktop}; my $name = $desktop->{'PrepName'}; my $exec = $desktop->{'PrepExec'}; $output .= "+ \"$dmicon{'fvwm_app'}$name\" Exec $exec\n"; } elsif ( $entry->{type} eq 'menu') { my $name = $entry->{'menu'}{'PrepName'}; my $id = "$menu_id-" . $entry->{'menu'}{'Name'}; $id =~ s/\s/_/g; $output .= "+ \"$dmicon{'fvwm_folder'}$name\" Popup \"$id\"\n"; } else { warn "wrong menu entry type: $entry->{type}"; } } $output .= "\n"; if ("$menu_id" eq "$menu_prefix-System_Tools") { $output .= "AddToMenu \"$menu_prefix-System_Tools\" " . "\"$dmicon{'fvwm_app'}Regenerate Applications Menu\" " . "FvwmForm FvwmForm-Desktop\n"; } return $output; } sub get_root_menu { my @menu_bases = (qw( applications debian-menu ) ); # XXX - TA: 2011-04-10: Is it enough to assume only one match here is # sufficient? foreach my $dir ( split( /:/, $xdg_config_dirs ), "/etc/xdg" ) { foreach my $menu_name (@menu_bases) { check_file("$dir/menus/$menu_name.menu"); if ( -f "$dir/menus/$menu_name.menu" ) { return "$dir/menus/$menu_name.menu"; } } } return ""; } sub get_app_dirs { my %used; my $ret = ''; return $ret unless check_app("kde-config"); my @kde_xdgdata = split( /:/, `kde-config --path xdgdata-apps` ); foreach (@kde_xdgdata) { s/\/applications\/*\s*$//; } foreach my $d (split( /:/, $xdg_data_dirs ), @kde_xdgdata, "/usr/share", "/opt/gnome/share") { my $dir = $d; $dir =~ s/\/*$//; next if defined $used{$dir}; next if check_file("$dir/applications") ne 'D'; $ret .= ':' if $ret ne ''; $ret .= "$dir/applications"; $used{$dir} = 1; } if ($verbose) { foreach ( split( ':', $ret ) ) { warn "app dirs $_\n"; } } return $ret; } sub get_desktop_dirs { my %used; my $ret = ''; foreach my $dir ( split( /:/, $xdg_data_dirs ), qw(/usr/share /opt/kde3/share /opt/gnome/share) ) { next if defined $used{$dir}; next if check_file("$dir/desktop-directories") ne 'D'; $ret .= ':' if $ret ne ''; $ret .= "$dir/desktop-directories"; $used{$dir} = 1; } warn "desktop dirs $ret\n" if $verbose; return $ret; } sub get_KDE_legacy_dirs { my %used; my @ret = (); my @legacy_dirs = (qw( /etc/opt/kde3/share/applnk /opt/kde3/share/applnk ) ); if (check_app("kde-config")) { push @legacy_dirs, reverse(split(/:/,`kde-config --path apps` )); } foreach my $d ( @legacy_dirs ) { my $dir = $d; chomp $dir; $dir =~ s/\/*$//; next if defined $used{$dir}; next if check_file("$dir") ne 'D'; $used{$dir} = 1; push @ret, $dir; } warn "KDE legacy dirs @ret\n" if $verbose; return @ret; } sub prepare_language_keys { my ($language) = @_; my @keys; $language =~ s/\.[^@]*//; # remove .ENCODING if ( $language =~ /^([^_]*)_([^@]*)@(.*)$/) { # LANG_COUNTRY@MODIFIER push @keys, $1 . '_' . $2 . '@' . $3; push @keys, $1 . '_' . $2; push @keys, $1 . '@' . $3; push @keys, $1; } elsif ($language =~ /^([^_]*)_([^@]*)$/) { # LANG_COUNTRY push @keys, $1 . '_' . $2; push @keys, $1; } elsif ($language =~ /^([^_]*)@(.*)$/) { # LANG@MODIFIER push @keys, $1 . '@' . $2; push @keys, $1; } elsif ($language =~ /^([^_@]*)$/) { # LANG push @keys, $1; } return @keys; } # Fixme, remove unsupported options. sub show_help { print <