cvsimport
[fvwm.git] / bin / fvwm-menu-desktop.in
blob6f66dba3170671c39813ffc7202d29637d17a1fc
1 #!@PERL@
3 # Modification History
5 # Changed on 11/30/10 by  (dane):
6 # - changed DIR filehandles to scalars, they're stepping on each other.
7 #   was a bug in xdg-menu.
8 # - changed default (only) format to fvwm2 and removed logic for other wms.
9 # - move mainline before all subs (move it back?).
10 # - removed the xdg_menu cache logic.
11 # - Remove $flag, $MENU_TYPE, $MENU_DESTROY for gtk vs. fvwm menu mode.
12 #   Actually removed all GTK MENU logic.
13 # - Added option to menu to regenerate the menus.
14 # - Remove xdg option root_menu.
15 # - Added fvwm-menu option to use Fvwm Icons package.
16 # - Style options from fvwmmenudesktop not carried over,
17 #   WM hints are sufficient to set mini-icon and icon.
18 # - Removed prototypes.  None were needed.
19 # - All filehandle names made local.
20 # - New option for su_gui, do path check for alternatives.
22 # - Change menu prefix from xdg-menu to FvwmMenu
24 # FIXME:
25 # - No testing for wm_icons has been done (is that fvwm-themes?).
26 # - Docs need to be updated.
27 # - fvwm-icons: okay, maybe the cat isn't a good default for Exec...
28 # - Running alacarte, I can see there are Application menus, and System menus.
29 #   Figure out the options to get both.
30 # - There are good programs like alacarte that are marked GNOME-ONLY.
31 #   Figure out how to get them in menus.
32 # - I think this should default to mini-icons enabled, but which
33 #   icon package should be assumed?
34 # - Need a way to select the /usr/share/icons icon sets with themes like
35 #   default/hicolor and size like 16x16 and 24x24.
36 # - Regenerate menus should prompt for a new command line.
37 # - sidepics, etc not tested.
38 # - iconname::: syntax needs investigation, I think some of it is obsolete,
39 #   needs a verifier, and some defaults.
40 # - Far too many lexical globals not bound to subroutines (c.f.
41 #    modularisation.)
42 # - I don't see the point to the path arguments.  I think they should
43 #   be obsoleted.
44 # - If I pass --fvwm-icons I don't need to set --enable-mini-icons.
45 #   Therefore I think enable mini-icons is pointless.
46 # - The "check" functions are useless.  Since this module doesn't get the
47 #   built in path, or the users path, it can't do the check.
48 # - Looks like there is no such thing as fvwm_toptitle, must have been a gtk thing?
50 # ---------------------------------------------------------------------------
51 #  fvwm-menu-desktop
52 #  See the man page fvwm-menu-desktop.1 for instructions.
54 #  Created on 22/07/1999 by Olivier Chapuis
56 #  Updated on 15/08/1999 by Mikhael Goikhman
58 #  Updated on 24/12/2010 by Dan Espen for xdg menus (see copyright below)
59 # ---------------------------------------------------------------------------
60 # COPYING
62 # The script is distributed by the same terms as fvwm itself.
63 # See GNU General Public License for details.
65 #----------------------------------------------------------------------------
67 # 25/12/2010 re-written, based heavily on
68 # xdg-menu for archlinux. based on suse xdg-menu written by <nadvornik@suse.cz>
69 # Sergej Pupykin <pupykin.s@gmail.com>
71 # >> Copyright (c) 2003 SuSE Linux AG, Nuernberg, Germany. All rights reserved.
72 # >> 
73 # >> Author: nadvornik@suse.cz
75 use version '5.0008';
76 use strict;
77 use warnings;
78 use Getopt::Long;
79 use Encode;
80 use I18N::Langinfo qw(langinfo CODESET);
81 use POSIX qw(locale_h);
82 use Digest::MD5 qw(md5_hex);
83 use XML::Parser;
85 my $xdg_data_dirs = $ENV{XDG_DATA_DIRS} || '';
86 my $xdg_config_dirs = $ENV{XDG_CONFIG_DIRS} || '';
87 my @PATH_DIRS = split(':',$ENV{PATH}); # for checking if applications exist
89 my $version = '@VERSION@';
90 my $menu_prefix='FvwmMenu';
91 my $DefaultAppDirs;
92 my $DefaultDirectoryDirs;
93 my @KDELegacyDirs;
94 my $desktop_name = 'fvwm2';
95 my $language = '';
96 my $charset = 'iso-8859-1';
97 my $root_cmd;
98 my $die_on_error = 0;
99 my $verbose = 0;
101 my @language_keys;
103 #my @accessed_files;
104 my $TERM_CMD = "xterm -e";
107 my %Desktop_entries;
108 my %Directory_entries;
110 my $root_menu;
111 my $help;
113 # Default for the mini-icons is mini/ (relatively to the ImagePath)
114 my $MINI_ICONS_DIR = 'mini/';
115 # Then the default for icon is ImagePath (consistent with kde, fvwm2gnome
116 # and almost consistent with wm-icons)
117 my $ICONS_DIR = '';
118 # For png icons
119 my $PNG_ICONS = '';
120 my $TRAN_MINI_ICONS = 'mini/';
121 my $TRAN_ICONS = '';
122 my $MINI_ICONS = 0;             # mini-icon disabled  (enable =1)
123 my $TRAN       = 0;             # mini-icon translation disabled (enable =1)
124 my $wm_icons   = 0;             # use wm-icons compatible menu icon names
125 my $fvwm_icons   = 0;           # use fvwm-icons compatible menu icon names
126 # check icons
127 my $check_icons = "";
128 my $check_mini_icons = "";
129 my @check_icons_path = ();
130 my @check_mini_icons_path = ();
131 my %DI;
132 my %dmicon;
133 # Menu Style option
134 my $MENU_STYLE = "";
135 my @menus_for_style = ();
136 # default for style
138 $DI{fvwm_app}      = 'mini-x.xpm:dh:%::'; # micon:law:placement:unused
139 $DI{fvwm_folder}   = 'folder.xpm:dh:%::'; # idem
140 $DI{fvwm_title}    = 'folder.xpm:dh:%::'; # micon:law:place:spic:color
141 $DI{fvwm_toptitle} = 'mini-k.xpm:no:%::'; # idem
142 my $OPT_INSTALL_PREFIX = '';
144 warn "invoked with args @ARGV\n" if $verbose;
146 GetOptions(
147        "enable-mini-icons"        => \$MINI_ICONS,
148            "enable-tran-mini-icons"   => \$TRAN,
149            "mini-icons-path:s"        => \$MINI_ICONS_DIR,
150            "png-icons-path:s"         => \$PNG_ICONS,
151            "tran-mini-icons-path:s"   => \$TRAN_MINI_ICONS,
152            "icon-toptitle:s"          => \$DI{"fvwm_toptitle"},
153            "icon-title:s"             => \$DI{"fvwm_title"},
154            "icon-folder:s"            => \$DI{"fvwm_folder"},
155            "icon-app:s"               => \$DI{"fvwm_app"},
156            "icon-style:s"             => \&obsolete,
157            "icons-path:s"             => \$ICONS_DIR,
158            "tran-icons-path:s"        => \$TRAN_ICONS,
159            "wm-icons"                 => \$wm_icons,
160            "fvwm-icons"               => \$fvwm_icons,
161            "check-mini-icon=s"        => \$check_mini_icons,
162            "check-icons=s"            => \$check_icons,
163            "help|h|?"                 => \&show_help,
164            "version|V"                => \&show_version,
165            "install-prefix:s"         => $OPT_INSTALL_PREFIX,
166            "type:s"                   => \&obsolete,
167            "fvwmgtk-alias=s"          => \&obsolete,
168            "title:s"                  => \&obsolete,
169            "name:s"                   => \&obsolete,
170            "enable-style"             => \&obsolete,
171            "enable-tran-style"        => \&obsolete,
172            "submenu-name-prefix:s"    => \&obsolete,
173            "dir:s"                    => \&obsolete,
174            "destroy-type:s"           => \&obsolete,
175            "xterm:s"                  => \$TERM_CMD,
176            "lang:s"                   => \$language,
177            "utf8"                     => \&obsolete,
178            "uniconv=s"                => \$charset,
179            "uniconv-exec=s"           => \&obsolete,
180            "menu-style=s"             => \$MENU_STYLE,
181            "check-app!"               => \&obsolete,
182            "time-limit=s"             => \&obsolete,
183            "merge-user-menu"          => \&obsolete,
185            "su_gui"  => \$root_cmd,
186            "verbose" => \$verbose
189 icon_init();
191 $DefaultAppDirs = get_app_dirs();
192 $DefaultDirectoryDirs = get_desktop_dirs();
194 $root_menu = get_root_menu();
196 @KDELegacyDirs = get_KDE_legacy_dirs();
198 $charset = langinfo(CODESET);
199 $language = setlocale(LC_MESSAGES);
201 if (! defined $root_cmd )
203     foreach (qw(gnomesu kdesu xdg_menu_su))
204     {
205             if (check_app($_))
206         {
207                 $root_cmd = $_;
208                 last;
209             }
210     }
213 if ($verbose)
215     warn qq|
216         DEBUG: root menu is $root_menu
217     DEBUG: charset is $charset.
218         DEBUG: language is $language.
219         DEBUG: root-cmd is $root_cmd.|;
222 @language_keys = prepare_language_keys($language);
224 unless (-f $root_menu)
226     warn "ERROR: Can't find root menu file.\n";
227     exit 1;
230 my $tree = read_menu($root_menu);
232 merge_menus($tree);
233 move_menus($tree);
235 my $menu = interpret_root($tree, '');
237 remove_allocated($menu);
238 preprocess_menu($menu);
239 remove_empty_menus($menu);
241 my $output = output_fvwm2_menu($menu);
242 print $output;
244 # output the menu style
245 if ($MENU_STYLE ne "")
247     foreach (@menus_for_style)
248     {
249             print qq|ChangeMenuStyle "$MENU_STYLE" "$_"\n|;
250     }
253 exit 0;
255 # Set DI to list of icons to use:
256 sub icon_init
258     my @list=();
259     my %law;
260     my %place;
261     my %spic;
262     my %scolor;
263     my $j = "";
264     my $l = "";
265     my $tmp_icon ="";
267     if ($wm_icons)
268     {
269         $MINI_ICONS = 1;
270         $MINI_ICONS_DIR = "";
271         $DI{"fvwm_toptitle"} = "menu/folder-open.xpm:ow";
272         $DI{"fvwm_title"}    = "menu/folder-open.xpm:ow";
273         $DI{"fvwm_folder"}   = "menu/folder.xpm:ow";
274         $DI{"fvwm_app"}      = "menu/utility.xpm:ow";
275     }
277     if ($fvwm_icons)
278     {
279         $MINI_ICONS = 1;
280         $MINI_ICONS_DIR = "";
281         $DI{"fvwm_toptitle"} = "mini.fvwm.xpm::%";
282         $DI{"fvwm_title"}    = "mini.folder.xpm::%";
283         $DI{"fvwm_folder"}   = "mini.ofolder.xpm::%";
284         $DI{"fvwm_app"}      = "mini.cat.xpm::%";
285     }
287     foreach my $i (keys(%DI))
288     {
289         @list = split(':',$DI{$i});
290         $dmicon{$i} = $list[0]; # "default" mini-icon
291         $law{$i}    = $list[1]; # default law
292         $place{$i}  = $list[2]; # default position
293         $spic{$i}   = $list[3]; # sidepic icon
294         $scolor{$i} = $list[4]; # color for sidepic
295         $DI{$i} = '';
296     }
298     if ($TRAN)
299     {
300         $MINI_ICONS = 1;
301     }
303     if ($MINI_ICONS_DIR ne 'mini/' or $ICONS_DIR ne '')
304     {
305             if ($MINI_ICONS_DIR ne '')
306         {
307             $MINI_ICONS_DIR =~ s/\/*$/\//;
308         }
310         if ($ICONS_DIR eq '')
311         {
312                 $ICONS_DIR = up_directory($MINI_ICONS_DIR);
313             }
314         elsif ($ICONS_DIR eq 'inpath')
315         {
316             $ICONS_DIR = '';
317         }
318             else 
319         {
320             $ICONS_DIR =~ s/\/*$/\// if $MINI_ICONS_DIR ne '';
321         }
322     }
324     if ($TRAN_MINI_ICONS ne 'mini/' or $TRAN_ICONS ne '')
325     {
326             if ($TRAN_MINI_ICONS ne '')
327         {
328             $TRAN_MINI_ICONS =~ s/\/*$/\//;
329         }
331         if ($TRAN_ICONS eq '')
332         {
333                 $TRAN_ICONS = up_directory($TRAN_MINI_ICONS);
334             }
335         elsif ($TRAN_ICONS eq 'inpath')
336         {
337             $TRAN_ICONS = '';
338         }
339             else 
340         {
341             $TRAN_ICONS =~ s/\/*$/\// if $TRAN_ICONS ne '';
342         }
343     }
345     $PNG_ICONS =~  s/\/*$/\// if $PNG_ICONS ne '';
347     # init default mini-icons, law, place, sidepic, color
348     foreach my $i (qw(fvwm_app fvwm_folder fvwm_title fvwm_toptitle))
349     {
350             warn "DEBUG: foreach $i.\n" if $verbose; # dje debug
351         # With the mini-icons-tran options we "use" gtk default
352         if ($TRAN)
353         {
354             $j = substr($i,index($i,'_'));
355             $j = "gtk$j";
356             $law{$i} = $law{$j};
357             $tmp_icon  = $dmicon{$j};
358             $tmp_icon  =~ s/\.png$/\.xpm/;
359             $dmicon{$i} = "$TRAN_MINI_ICONS$tmp_icon";
360         }
361         else
362         {
363             $dmicon{$i} = "$MINI_ICONS_DIR$dmicon{$i}";
364         }
366         if ($verbose)
367         {
368             while (my ($key,$value) = each %dmicon)
369             {
370                 warn "INTERMEDIATE icons to use $key -> $value.\n";
371             }
372             }
373             @list = split(':',$DI{$i});
374             $l = @list;
375             while ($l <= 5)
376         {
377             push(@list,'');
378             ++$l;
379         }
380             $law{$i}     = $list[1] if ($list[1] eq 'no' or $list[1] eq 'ow'
381                        or $list[1] eq 're' or $list[1] eq 'dh');
382             $dmicon{$i}  = "$MINI_ICONS_DIR$list[0]" if $list[0] ne '';
383             $place{$i}   = '*' if $list[2] eq 'up';
384             $dmicon{$i}  = "$place{$i}$dmicon{$i}$place{$i}";
385             $dmicon{$i}  = '' if $law{$i} eq 'no' or $MINI_ICONS == 0;
387         if ($list[3] ne '')
388         {
389             $spic{$i} = "\@$list[3]\@";
390         }
391             else 
392         {
393             $spic{$i} = '';
394         }
396         if ($list[4] ne '' and $list[3] ne '')
397         {
398             $scolor{$i} = "\^$list[4]\^";
399         }
400             else 
401         {
402             $scolor{$i} = '';
403         }
405         if ($check_mini_icons ne "")
406         {
407             @check_mini_icons_path = split(":", $check_mini_icons);
408         }
410         if ($check_icons ne "")
411         {
412             @check_icons_path = split(":", $check_icons);
413         }
415         if ($verbose)
416         {
417             while (my ($key, $value) = each %dmicon)
418             {
419                 warn "icons to use $key -> $value.\n";
420             }
421         }
422         @list = split(':',$DI{$i});
423         $l = @list;
424         while ($l <= 5)
425         {
426             push(@list,''); 
427             ++$l;
428         }
429         $law{$i}     = $list[1] if ($list[1] eq 'no' or $list[1] eq 'ow'
430                         or $list[1] eq 're' or $list[1] eq 'dh');
431         $dmicon{$i}  = "$MINI_ICONS_DIR$list[0]" if $list[0] ne '';
432         $place{$i}   = '%';             # default
434         if ($list[2] eq 'up')
435         {
436             $place{$i} = '*';
437         }
438         $dmicon{$i}  = "$place{$i}$dmicon{$i}$place{$i}";
439         $dmicon{$i}  = '' if ($law{$i} eq 'no' || $MINI_ICONS == 0);
440         if ($list[3] ne '')
441         {
442             $spic{$i} = "\@$list[3]\@";
443         }
444         else 
445         {
446             $spic{$i} = '';
447         }
448         if ($list[4] ne '' and $list[3] ne '')
449         {
450             $scolor{$i} = "\^$list[4]\^";
451         }
452         else 
453         {
454             $scolor{$i} = '';
455         }
457         if ($check_mini_icons ne "")
458         {
459             @check_mini_icons_path = split(":", $check_mini_icons);
460         }
462         if ($check_icons ne "")
463         {
464             @check_icons_path = split(":", $check_icons);
465         }
466     } # end while
467     if ( $verbose )
468     {
469             while (my ($key, $value) = each %dmicon)
470         {
471                 warn "icons to use $key -> $value.\n";
472             }
473     }
476 # Compute cd ..
477 sub up_directory
479         my($dir) = @_;
481         if ($dir eq '')
482     {
483         return '../';
484     }
486         chop($dir);
488     if ($dir !~ /\//)
489     {
490         return '';
491     }
492         $dir = substr($dir, 0, rindex($dir, '/') + 1);
494         return $dir;
497 sub check_file
499     my ($file) = @_;
500     unless (-e $file)
501     {
502         return '';
503     }
505     if (-d $file)
506     {
507         return 'D';
508     }
510     return 'F';
513 sub scan_AppDir
515     my ($pool, $dir, $topdir) = @_;
517     check_file($dir);
519     $topdir = $dir unless defined $topdir;
521     return if check_file($dir) ne 'D';
523     opendir( my $dir_fh, $dir ) or return;
524     foreach my $entry ( readdir($dir_fh) )
525     {
526         if (-f "$dir/$entry" and $entry =~ /\.desktop$/)
527         {
528             read_desktop_entry($pool, "$dir/$entry", $topdir);
529         }
530         elsif (-d "$dir/$entry" and $entry !~ /^\.{1,2}$/
531                 and $entry ne '.hidden')
532         {
533             scan_AppDir($pool, "$dir/$entry", $topdir);
534         }
535     }
536     closedir $dir_fh;
539 sub scan_DirectoryDir
541     my ($pool, $dir, $topdir) = @_;
543     check_file($dir);
544     $topdir = $dir unless defined $topdir;
546     opendir( my $dir_fh, $dir ) or return;
547     foreach my $entry (readdir($dir_fh))
548     {
549         if (-f "$dir/$entry" and $entry =~ /\.directory$/)
550         {
551             read_directory_entry( $pool, "$dir/$entry", $topdir );
552         }
553         elsif (-d "$dir/$entry" and $entry !~ /^\.{1,2}$/
554                 and $entry ne '.hidden')
555         {
556             scan_DirectoryDir($pool, "$dir/$entry", $topdir);
557         }
558     }
559     closedir $dir_fh;
562 sub read_directory_entry
564     my ($pool, $file, $topdir) = @_;
566     unless (defined $Directory_entries{$file})
567     {
568         check_file($file);
570         if ($verbose)
571         {
572                 warn "Read directory entry, opening file $file.\n";
573             }
574         open( my $file_fh, "<", $file ) or return;
575         my $in_desktop_entry = 0;
576         my %entry;
577         while (<$file_fh>)
578         {
579             if (/^\[/)
580             {
581                 if (/^\[Desktop Entry\]/)
582                 {
583                     $in_desktop_entry = 1;
584                 }
585                 elsif (/^\[.*\]/)
586                 {
587                     $in_desktop_entry = 0;
588                 }
589             }
590             elsif ($in_desktop_entry and /^([^=]*)=([^[:cntrl:]]*)/)
591             {
592                 $entry{$1} = $2;
593             }
594         }
595         close($file_fh);
597         my $id = $file;
598         $id =~ s/^$topdir//;
599         $id =~ s/^\/*//;
600         $id =~ s/\//-/g;
601         $entry{'id'} = $id;
602         $Directory_entries{$file} = \%entry;
603     }
604     my $entry = $Directory_entries{$file};
605     $pool->{'Directory_entries'}{ $entry->{'id'} } = $entry;
608 sub check_show_in
610     my ($entry) = @_;
612     return 1 unless defined $entry;
614     my (%OnlyShowIn, %NotShowIn);
616     if (defined $entry->{'OnlyShowIn'})
617     {
618         foreach my $showin (split /;/, $entry->{'OnlyShowIn'})
619         {
620             $OnlyShowIn{$showin} = 1;
621         }
623         return 0 unless defined $OnlyShowIn{$desktop_name};
624     }
626     if (defined $entry->{'NotShowIn'})
627     {
628         foreach my $showin (split /;/, $entry->{'NotShowIn'})
629         {
630             $NotShowIn{$showin} = 1;
631         }
633         return 0 if defined $NotShowIn{$desktop_name};
634     }
636     return 1;
639 sub read_desktop_entry
641     my ($pool, $file, $topdir) = @_;
643     unless (defined $Desktop_entries{$file})
644     {
645         check_file($file);
646     }
648         if ($verbose)
649     {
650             warn "Read desktop entry, opening file $file.\n";
651         }
653     open( my $file_fh, "<", $file ) or return;
655     my $entry = $Desktop_entries{$file};
657     return unless defined $entry->{'Name'};
658     return unless defined $entry->{'Exec'};
660     if (defined $entry->{'Hidden'} and $entry->{'Hidden'} eq 'true')
661     {
662             return;
663     }
665     #FIXME, an option for this would be good
667     if (defined $entry->{'NoDisplay'} and  $entry->{'NoDisplay'} eq 'true')
668     {
669             return;
670     }
672     return unless check_show_in($entry);
674     if (defined $entry->{'NotShowIn'} and
675         $entry->{'NotShowIn'} eq $desktop_name)
676     {
677         return;
678     }
680     if (defined $pool and defined $entry->{'Categories'})
681     {
682         foreach my $category (split /;/, $entry->{'Categories'})
683         {
684             $pool->{'Categories'}{$category} = []
685                 unless defined $pool->{'Categories'}{$category};
687             push @{ $pool->{'Categories'}{$category} }, $entry;
688         }
689         $pool->{'Desktop_entries'}{ $entry->{'id'} } = $entry;
690     }
692     return $entry;
695 sub read_desktop_entries
697     my ($directory_paths, $desktop_paths) = @_;
698     my $pool = {
699         'Desktop_entries'   => {},
700         'Categories'        => {},
701         'Directory_entries' => {},
702         'Directory_paths'   => $directory_paths,
703         'Desktop_paths'     => $desktop_paths
704     };
706     foreach my $dir (split /:/, $directory_paths)
707     {
708         next if $dir =~ /^\s*$/;
709         scan_DirectoryDir( $pool, $dir );
710     }
712     foreach my $dir (split /:/, $desktop_paths)
713     {
714         next if $dir =~ /^\s*$/;
715         scan_AppDir( $pool, $dir );
716     }
718     return $pool;
721 sub get_directory_entry
723     my ($entry, $pool) = @_;
724     return $pool->{'Directory_entries'}{$entry};
727 sub interpret_Include
729     my ( $tree, $entries, $pool ) = @_;
730     my %exist;
731     my @list = interpret_entry_node( $tree, 'Or', $pool );
732     foreach my $e (@$entries)
733     {
734         if ( $e->{type} eq 'desktop' )
735         {
736             $exist{ $e->{desktop} } = 1;
737         }
738     }
740     foreach my $entry (@list)
741     {
742         next if $exist{$entry};
743         push @$entries, { type => 'desktop', desktop => $entry };
744         $entry->{'refcount'}++;
745         $exist{$entry} = 1;
746     }
749 sub interpret_Exclude
751     my ( $tree, $entries, $pool ) = @_;
752     my @list = interpret_entry_node( $tree, 'Or', $pool );
753     foreach my $entry (@list)
754     {
755         my $i = 0;
756         while ( defined $entries->[$i] )
757         {
758             my $exist = $entries->[$i];
759             if ($exist->{type} eq 'desktop' and
760                 $exist->{desktop} eq $entry )
761             {
762                 splice @$entries, $i, 1;
763                 $entry->{'refcount'}--;
764             }
765             else 
766             {
767                 $i++;
768             }
769         }
770     }
773 sub interpret_entry_node
775     my ( $tree, $node, $pool ) = @_;
776     my $i = 0;
777     $i++ if ( ref( $tree->[$i] ) eq 'HASH' );
778     my @subtree;
779     while (defined $tree->[$i])
780     {
781         if ($tree->[$i] eq 'Filename')
782         {
783             $i++;
784             if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0')
785             {
786                 my $entry = $tree->[$i][2];
787                 if (defined $pool->{'Desktop_entries'}{$entry})
788                 {
789                     push @subtree, [ $pool->{'Desktop_entries'}{$entry} ];
790                 }
791                 else
792                 {
793                     push @subtree, [];
794                 }
795             }
796             else
797             {
798                 warn "Filename\n";
799                 exit 1 if $die_on_error;
800             }
801             $i++;
802         }
803         elsif ($tree->[$i] eq 'Category')
804         {
805             $i++;
806             if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0')
807             {
808                 my $category = $tree->[$i][2];
809                 if (defined $pool->{'Categories'}{$category})
810                 {
811                     push @subtree, $pool->{'Categories'}{$category};
812                 }
813                 else
814                 {
815                     push @subtree, [];
816                 }
817             }
818             else
819             {
820                 warn "Category\n";
821                 exit 1 if $die_on_error;
822             }
823             $i++;
824         }
825         elsif ($tree->[$i] eq 'All')
826         {
827             $i++;
828             if (values %{ $pool->{'Desktop_entries'} } > 0)
829             {
830                 push @subtree, [ values %{ $pool->{'Desktop_entries'} } ];
831             }
832             else
833             {
834                 push @subtree, [];
835             }
836             $i++;
837         }
838         elsif ($tree->[$i] eq '0')
839         {
840             $i++;
841             $i++;
842         }
843         else
844         {
845             my @res = interpret_entry_node(
846                 $tree->[ $i + 1 ], $tree->[$i], $pool
847             );
849             push @subtree, \@res;
850             $i++;
851             $i++;
852         }
853     }
855     if ($node eq 'Or')
856     {
857         my %used;
858         my @res;
859         foreach my $st (@subtree)
860         {
861             foreach my $entry (@$st)
862             {
863                 if (!defined $used{$entry})
864                 {
865                     push @res, $entry;
866                     $used{$entry} = 1;
867                 }
868             }
869         }
870         return @res;
871     }
872     elsif ($node eq 'And')
873     {
874         my %used;
875         my @res;
876         my $cnt     = @subtree;
877         my $min     = @{ $subtree[0] };
878         my $min_idx = 0;
879         my $idx     = 0;
880         foreach my $st (@subtree)
881         {
882             my $num = @$st;
883             if ($num < $min)
884             {
885                 $min     = $num;
886                 $min_idx = $idx;
887             }
889             my %dupes;
890             foreach my $entry (@$st)
891             {
892                 next if $dupes{$entry};
893                 $dupes{$entry} = 1;
895                 if (!defined $used{$entry})
896                 {
897                     $used{$entry} = 1;
898                 }
899                 else
900                 {
901                     $used{$entry}++;
902                 }
903             }
904             $idx++;
905         }
907         return () if $cnt == 0;
909         foreach my $entry (@{ $subtree[$min_idx] })
910         {
911             push @res, $entry if $used{$entry} == $cnt;
912         }
914         return @res;
915     }
916     elsif ($node eq 'Not')
917     {
918         my %used;
919         my @res;
921         my $cnt = @subtree;
922         foreach my $st (@subtree) {
923             foreach my $entry (@$st) {
924                 $used{$entry} = 1;
925             }
926         }
927         return if $cnt == 0;
928         foreach my $entry (values %{ $pool->{'Desktop_entries'} })
929         {
930             push @res, $entry if !defined $used{$entry};
931         }
933         return @res;
934     }
935     else
936     {
937         warn "Can't use '$node' inside <Include> or <Exclude>\n";
938         exit 1 if $die_on_error;
939         return ();
940     }
943 sub interpret_root
945     my ($tree, $topdir) = @_;
947     if ($tree->[0] eq 'Menu')
948     {
949         return interpret_menu( $tree->[1] );
950     }
951     else
952     {
953         warn "No toplevel Menu\n";
954         exit 1 if $die_on_error;
955         return;
956     }
959 sub interpret_menu
961     my ($tree, $directory_paths, $desktop_paths) = @_;
963     $directory_paths = '' unless defined $directory_paths;
964     $desktop_paths   = '' unless defined $desktop_paths;
966     my %menu = (
967         'entries'         => [],
968         'OnlyUnallocated' => 0,
969         'DontShowIfEmpty' => 0,
970         'Deleted'         => 0
971     );
973     my $i = 0;
975     $i++ if ref $tree->[$i] eq 'HASH';
977     while (defined $tree->[$i])
978     {
979         if ($tree->[$i] eq 'AppDir')
980         {
981             if (ref( $tree->[ $i + 1 ][0] ) eq 'HASH'
982                 and $tree->[ $i + 1 ][1] eq '0')
983             {
984                 $desktop_paths .= ':' . $tree->[ $i + 1 ][2];
985                 splice @$tree, $i, 2;
986             }
987             else 
988             {
989                 warn "wrong AppDir\n";
990                 exit 1 if $die_on_error;
991                 $i++;
992                 $i++;
993             }
994         }
995         elsif ($tree->[$i] eq 'DefaultAppDirs')
996         {
997             $desktop_paths .= ':' . $DefaultAppDirs;
998             splice @$tree, $i, 2;
999         }
1000         elsif ($tree->[$i] eq 'DirectoryDir')
1001         {
1002             if (ref( $tree->[ $i + 1 ][0]) eq 'HASH'
1003                 and $tree->[ $i + 1 ][1] eq '0')
1004             {
1005                 $directory_paths .= ':' . $tree->[ $i + 1 ][2];
1006                 splice @$tree, $i, 2;
1007             }
1008             else 
1009             {
1010                 warn "wrong DirectoryDir\n";
1011                 exit 1 if $die_on_error;
1012                 $i++;
1013                 $i++;
1014             }
1015         }
1016         elsif ($tree->[$i] eq 'DefaultDirectoryDirs')
1017         {
1018             $directory_paths .= ':' . $DefaultDirectoryDirs;
1019             splice @$tree, $i, 2;
1020         }
1021         else
1022         {
1023             $i++;
1024             $i++;
1025         }
1026     }
1028     $menu{directory_paths} = $directory_paths;
1029     $menu{desktop_paths}   = $desktop_paths;
1031     my $pool = read_desktop_entries( $directory_paths, $desktop_paths );
1033     $i = 0;
1034     $i++ if ref $tree->[$i] eq 'HASH';
1036     while (defined $tree->[$i])
1037     {
1038         if ($tree->[$i] eq 'Menu')
1039         {
1040             $i++;
1041             my $submenu = interpret_menu(
1042                 $tree->[$i], $directory_paths, $desktop_paths
1043             );
1045             push( @{ $menu{'entries'} },
1046                     { type => 'menu', menu => $submenu }
1047             );
1048             $i++;
1049         }
1050         elsif ($tree->[$i] eq 'Name')
1051         {
1052             $i++;
1053             if (ref($tree->[$i][0]) eq 'HASH' and $tree->[$i][1] eq '0')
1054             {
1055                 $menu{'Name'} = $tree->[$i][2];
1056                 exit 1 if $die_on_error;
1057             }
1058             $i++;
1059         }
1060         elsif ($tree->[$i] eq 'Directory')
1061         {
1062             $i++;
1063             if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0')
1064             {
1065                 $menu{'Directory'} = get_directory_entry(
1066                     $tree->[$i][2], $pool
1067                 );
1068             }
1069             else
1070             {
1071                 warn "wrong Directory\n";
1072                 exit 1 if $die_on_error;
1073             }
1074             $i++;
1075         }
1076         elsif ($tree->[$i] eq 'OnlyUnallocated')
1077         {
1078             $menu{'OnlyUnallocated'} = 1;
1079             $i++;
1080             $i++;
1081         }
1082         elsif ($tree->[$i] eq 'DontShowIfEmpty')
1083         {
1084             $menu{'DontShowIfEmpty'} = 1;
1085             $i++;
1086             $i++;
1087         }
1088         elsif ($tree->[$i] eq 'Deleted')
1089         {
1090             $menu{'Deleted'} = 1;
1091             $i++;
1092             $i++;
1093         }
1094         elsif ($tree->[$i] eq 'NotDeleted')
1095         {
1096             $menu{'Deleted'} = 0;
1097             $i++;
1098             $i++;
1099         }
1100         elsif ($tree->[$i] eq 'Include')
1101         {
1102             $i++;
1103             interpret_Include($tree->[$i], $menu{'entries'}, $pool);
1104             $i++;
1105         }
1106         elsif ($tree->[$i] eq 'Exclude')
1107         {
1108             $i++;
1109             interpret_Exclude($tree->[$i], $menu{'entries'}, $pool);
1110             $i++;
1111         }
1112         elsif ($tree->[$i] eq '0')
1113         {
1114             $i++;
1115             if ($tree->[$i] !~ /^\s*$/)
1116             {
1117                 print STDERR "skip '$tree->[$i]'\n";
1118                 exit 1 if $die_on_error;
1119             }
1120             $i++;
1121         }
1122         else
1123         {
1124             warn "Unknown '$tree->[$i]':\n";
1125             $i++;
1126             warn "        '@{$tree->[$i]}'\n";
1127             $i++;
1128             exit 1 if $die_on_error;
1129         }
1130     }
1132     return \%menu;
1135 sub read_menu
1137     my ($file, $basedir) = @_;
1139     if ($file !~ /^\// and defined $basedir)
1140     {
1141         $file = "$basedir/$file";
1142     }
1144     unless (defined $basedir)
1145     {
1146         $basedir = $file;
1147         $basedir =~ s/\/[^\/]*$//;
1148     }
1150     unless (check_file($file))
1151     {
1152         warn "WARNING: '$file' does not exist\n";
1153         return [ 'Menu', [ {} ] ];
1154     }
1156     warn "reading '$file'\n" if $verbose;
1158     my $parser = XML::Parser->new(Style => 'Tree');
1159     my $tree = $parser->parsefile($file);
1161     my $DefaultMergeDir = $file;
1162     $DefaultMergeDir =~ s/^.*\///;
1163     $DefaultMergeDir =~ s/\.menu$/-merged/;
1165     read_includes($tree, $basedir, $DefaultMergeDir);
1167     return $tree;
1170 sub read_menu_dir
1172     my ($dir, $basedir) = @_;
1174     my @out;
1176     if ($dir !~ /^\// and defined $basedir)
1177     {
1178         $dir = "$basedir/$dir";
1179     }
1181     if (check_file($dir) ne 'D')
1182     {
1183         return [];
1184     }
1186     opendir( my $dir_fh, $dir );
1187     foreach my $entry (readdir($dir_fh))
1188     {
1190         if (-f "$dir/$entry" and $entry =~ /\.menu$/)
1191         {
1192             my $menu = read_menu("$dir/$entry");
1193             $menu = remove_toplevel_Menu($menu);
1194             push @out, @$menu;
1195         }
1196     }
1197     closedir $dir_fh;
1199     return \@out;
1202 sub quote_xml
1204     my ($txt) = @_;
1206     $txt =~ s/&/&amp;/g;
1207     $txt =~ s/</&lt;/g;
1208     $txt =~ s/>/&gt;/g;
1209     return $txt;
1212 sub read_legacy_dir
1214     my ($dir, $basedir) = @_;
1215     my $out;
1217     $dir =~ s/\/*$//;
1219     $basedir = $dir unless defined $basedir;
1221     return "" if check_file($dir) ne 'D';
1223     $out = "<Menu>\n";
1225     if ($dir eq $basedir)
1226     {
1227         my $xmldir = quote_xml($dir);
1229         $out .= "<AppDir>$xmldir</AppDir>\n";
1230         $out .= "<DirectoryDir>$xmldir</DirectoryDir>\n";
1231     }
1232     else
1233     {
1234         my $name = $dir;
1235         $name =~ s/\/*$//;
1236         $name =~ s/^.*\///;
1238         $name = quote_xml($name);
1239         $out .= "<Name>$name</Name>\n";
1240     }
1242     if (-f "$dir/.directory")
1243     {
1244         my $dir_id = "$dir/.directory";
1245         $dir_id =~ s/^$basedir//;
1246         $dir_id =~ s/^\///;
1247         $dir_id = quote_xml($dir_id);
1249         $out .= "<Directory>$dir_id</Directory>\n";
1250     }
1252     if (opendir(my $dir_fh, $dir))
1253     {
1254         foreach my $entry (readdir($dir_fh))
1255         {
1256             if (-f "$dir/$entry" and $entry =~ /\.desktop$/)
1257             {
1258                 my $id = "$dir/$entry";
1259                 $id =~ s/^$basedir//;
1260                 $id =~ s/^\///;
1261                 $id =~ s/\//-/g;
1262                 $id = quote_xml($id);
1264                 my $desktop = read_desktop_entry(
1265                     undef, "$dir/$entry", $basedir
1266                 );
1268                 $out .= "<Include><Filename>$id</Filename></Include>\n"
1269                     unless defined $desktop->{'Categories'};
1270             }
1271             elsif (-d "$dir/$entry" and $entry !~ /^\.{1,2}$/ and
1272                     $entry ne '.hidden')
1273             {
1274                 $out .= read_legacy_dir( "$dir/$entry", $basedir );
1275             }
1276         }
1277         closedir $dir_fh;
1278     }
1280     $out .= "</Menu>\n";
1281     return $out;
1284 sub remove_toplevel_Menu
1286     my ($tree) = @_;
1288     if ($tree->[0] eq 'Menu')
1289     {
1290         shift @{ $tree->[1] } if ref $tree->[1][0] eq 'HASH';
1291         return $tree->[1];
1292     }
1293     else 
1294     {
1295         warn "No toplevel Menu\n";
1296         exit 1 if $die_on_error;
1297         return;
1298     }
1301 sub read_includes
1303     my ($tree, $basedir, $DefaultMergeDir) = @_;
1304     my $i = 0;
1305     $i++ if ref $tree->[$i] eq 'HASH';
1307     while (defined $tree->[$i])
1308     {
1309         if ($tree->[$i] eq 'MergeFile')
1310         {
1311             if (ref( $tree->[ $i + 1 ][0]) eq 'HASH'
1312                 and $tree->[ $i + 1 ][1] eq '0')
1313             {
1314                 my $add_tree = read_menu(
1315                     $tree->[ $i + 1 ][2], $basedir
1316                 );
1317                 $add_tree = remove_toplevel_Menu($add_tree);
1319                 splice @$tree, $i, 2, @$add_tree;
1320             }
1321             else
1322             {
1323                 warn "wrong MergeFile\n";
1324                 exit 1 if $die_on_error;
1325                 $i++;
1326                 $i++;
1327             }
1328         }
1329         elsif ($tree->[$i] eq 'MergeDir')
1330         {
1331             if (ref( $tree->[ $i + 1 ][0] ) eq 'HASH'
1332                 and $tree->[ $i + 1 ][1] eq '0')
1333             {
1334                 my $add_tree = read_menu_dir( $tree->[ $i + 1 ][2], $basedir );
1335                 splice @$tree, $i, 2, @$add_tree;
1336             }
1337             else
1338             {
1339                 warn "wrong MergeFile\n";
1340                 exit 1 if $die_on_error;
1341                 $i++;
1342                 $i++;
1343             }
1344         }
1345         elsif ($tree->[$i] eq 'DefaultMergeDirs')
1346         {
1347             my $add_tree = read_menu_dir( $DefaultMergeDir, $basedir );
1348             splice @$tree, $i, 2, @$add_tree;
1349         }
1350         elsif ($tree->[$i] eq 'LegacyDir')
1351         {
1352             if (ref( $tree->[ $i + 1 ][0] ) eq 'HASH'
1353                 and $tree->[ $i + 1 ][1] eq '0')
1354             {
1355                 if (-d $tree->[ $i + 1 ][2])
1356                 {
1357                     my $xml = read_legacy_dir( $tree->[ $i + 1 ][2] );
1358                     warn "reading legacy directory '" . $tree->[ $i + 1 ][2] . 
1359                         "'\n" if $verbose;
1361                     my $parser = XML::Parser->new(Style => 'Tree');
1362                     my $add_tree = $parser->parse($xml);
1363                     $add_tree = remove_toplevel_Menu($add_tree);
1364                     splice @$tree, $i, 2, @$add_tree;
1365                 }
1366                 else
1367                 {
1368                     warn "legacy directory '"
1369                       . $tree->[ $i + 1 ][2]
1370                       . "' not found\n"
1371                       if $verbose;
1372                     splice @$tree, $i, 2, ();
1373                 }
1374             }
1375             else
1376             {
1377                 warn "wrong LegacyDir\n";
1378                 exit 1 if $die_on_error;
1379                 $i++;
1380                 $i++;
1381             }
1382         }
1383         elsif ($tree->[$i] eq 'KDELegacyDirs')
1384         {
1385             my @out;
1386             foreach my $dir (@KDELegacyDirs)
1387             {
1388                 my $xml = read_legacy_dir($dir);
1389                 warn "reading legacy directory '$dir'\n" if $verbose;
1391                 my $parser = new XML::Parser( Style => 'Tree' );
1392                 my $add_tree = $parser->parse($xml);
1393                 $add_tree = remove_toplevel_Menu($add_tree);
1394                 push @out, @$add_tree;
1395             }
1396             splice @$tree, $i, 2, @out;
1397         }
1398         elsif ($tree->[$i] eq 'Menu')
1399         {
1400             $i++;
1401             read_includes( $tree->[$i], $basedir, $DefaultMergeDir );
1402             $i++;
1403         }
1404         else
1405         {
1406             $i++;
1407             $i++;
1408         }
1409     }
1412 sub get_menu_name
1414     my ($tree) = @_;
1415     my $name;
1417     my $i = 0;
1419     $i++ if ref $tree->[$i] eq 'HASH';
1421     while (defined $tree->[$i])
1422     {
1423         if ($tree->[$i] eq 'Name')
1424         {
1425             $i++;
1426             if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0')
1427             {
1428                 $name = $tree->[$i][2];
1429                 last;
1430             }
1431             else
1432             {
1433                 warn "wrong Name\n";
1434             }
1435             $i++;
1436         }
1437         else
1438         {
1439             $i++;
1440             $i++;
1441         }
1442     }
1444     unless (defined $name)
1445     {
1446         warn "Menu has no name element\n";
1447     }
1449     return $name;
1452 sub append_menu
1454     my ($target, $source) = @_;
1456     my $i = 0;
1457     $i++ if ref $source->[$i] eq 'HASH';
1459     while (defined $source->[$i])
1460     {
1461         if ($source->[$i] ne 'Name')
1462         {
1463             push @$target, $source->[$i];
1464             push @$target, $source->[ $i + 1 ];
1465         }
1466         $i++;
1467         $i++;
1468     }
1471 sub merge_menus
1473     my ($tree) = @_;
1475     my %used;    #menu name already used
1477     my $i = 0;
1478     $i++ if ref $tree->[$i] eq 'HASH';
1480     while (defined $tree->[$i])
1481     {
1482         if ($tree->[$i] eq 'Menu')
1483         {
1484             my $name = get_menu_name($tree->[ $i + 1 ]);
1485             if (defined $used{$name})
1486             {
1487                 my $target = $used{$name};
1488                 append_menu($tree->[$target], $tree->[ $i + 1 ]);
1490                 splice @$tree, $i, 2;
1491             }
1492             else
1493             {                           # first appearance
1494                 $used{$name} = $i + 1;
1495                 $i++;
1496                 $i++;
1497             }
1498         }
1499         else 
1500         {
1501             $i++;
1502             $i++;
1503         }
1504     }
1506     $i = 0;
1507     $i++ if ref $tree->[$i] eq 'HASH';
1509     while (defined $tree->[$i])
1510     {
1511         if ($tree->[$i] eq 'Menu')
1512         {
1513             merge_menus($tree->[ $i + 1 ]);
1514         }
1515         $i++;
1516         $i++;
1517     }
1520 sub read_Move
1522     my ( $tree, $hash ) = @_;
1523     my $i = 0;
1524     my $old = '';
1525     $i++ if ref $tree->[$i] eq 'HASH';
1527     while (defined $tree->[$i])
1528     {
1529         if ($tree->[$i] eq 'Old')
1530         {
1531             $i++;
1532             if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0')
1533             {
1534                 $old = $tree->[$i][2];
1535             }
1536             else
1537             {
1538                 warn "wrong Old\n";
1539                 exit 1 if $die_on_error;
1540             }
1541             $i++;
1542         }
1543         if ($tree->[$i] eq 'New')
1544         {
1545             $i++;
1546             if (ref( $tree->[$i][0] ) eq 'HASH' and $tree->[$i][1] eq '0')
1547             {
1548                 $hash->{$old} = $tree->[$i][2];
1549             }
1550             else
1551             {
1552                 warn "wrong New\n";
1553                 exit 1 if $die_on_error;
1554             }
1555             $i++;
1556         }
1557         else
1558         {
1559             $i++;
1560             $i++;
1561         }
1562     }
1565 sub find_menu_in_tree
1567     my ( $path, $tree ) = @_;
1569     my $root = $path;
1570     $root =~ s/\/.*$//;
1572     my $subpath = $path;
1573     $subpath =~ s/^[^\/]*\/*//;
1575     my $i = 0;
1576     $i++ if ref $tree->[$i]  eq 'HASH';
1578     while (defined $tree->[$i])
1579     {
1580         if ($tree->[$i] eq 'Menu')
1581         {
1582             if ($root eq get_menu_name( $tree->[ $i + 1 ]))
1583             {
1584                 if ($subpath eq '')
1585                 {
1586                     return {
1587                         'parent' => $tree,
1588                         'index'  => $i,
1589                         'menu'   => $tree->[ $i + 1 ]
1590                     };
1591                 }
1592                 return find_menu_in_tree( $subpath, $tree->[ $i + 1 ] );
1593             }
1594         }
1595         $i++;
1596         $i++;
1597     }
1599     #FIXME - TA:  Don't return undef here, it's bad.
1600     return undef;
1603 sub copy_menu
1605     my ($path, $tree) = @_;
1606     my $tail;
1607     my $child;
1609     foreach my $elem (reverse split( /\//, $path))
1610     {
1611         next if $elem eq '';
1612         my $menu = [ {}, 'Name', [ {}, 0, $elem ] ];
1613         push @$menu, ( 'Menu', $child ) if defined $child;
1614         $tail = $menu unless defined $tail;
1615         $child = $menu;
1616     }
1617     append_menu( $tail, $tree );
1618     return $child;
1621 sub move_menus
1623     my ($tree) = @_;
1624     my %move;
1625     my $i = 0;
1626     $i++ if ref $tree->[$i] eq 'HASH';
1628     while (defined $tree->[$i])
1629     {
1630         if ($tree->[$i] eq 'Move')
1631         {
1632             read_Move($tree->[ $i + 1 ], \%move);
1633             splice @$tree, $i, 2;
1634         }
1635         else
1636         {
1637             $i++;
1638             $i++;
1639         }
1640     }
1642     foreach my $source (keys %move)
1643     {
1644         my $sourceinfo = find_menu_in_tree($source, $tree);
1646         if (defined $sourceinfo)
1647         {
1648             my $target = copy_menu($move{$source}, $sourceinfo->{'menu'});
1649             splice @{ $sourceinfo->{'parent'} }, $sourceinfo->{'index'}, 2;
1650             push @$tree, ('Menu', $target);
1651             merge_menus($tree);
1652         }
1653     }
1654     $i = 0;
1655     $i++ if ref $tree->[$i] eq 'HASH';
1657     while (defined $tree->[$i])
1658     {
1659         if ($tree->[$i] eq 'Menu')
1660         {
1661             move_menus($tree->[ $i + 1 ]);
1662         }
1663         $i++;
1664         $i++;
1665     }
1668 sub remove_allocated
1670     my ($menu) = @_;
1672     my $i = 0;
1673     while ($i < @{ $menu->{'entries'} })
1674     {
1675         my $entry = $menu->{'entries'}[$i];
1677         if ($entry->{type} eq 'menu')
1678         {
1679             remove_allocated( $entry->{menu} );
1680             $i++;
1681         }
1682         elsif ($entry->{type} eq 'desktop'
1683                 and  $menu->{'OnlyUnallocated'}
1684                 and $entry->{desktop}{'refcount'} > 1)
1685         {
1686             $entry->{desktop}{'refcount'}--;
1687             splice @{ $menu->{'entries'} }, $i, 1;
1688         }
1689         else 
1690         {
1691             $i++;
1692         }
1693     }
1694     return 0;
1697 sub remove_empty_menus
1699     my ($menu) = @_;
1701     my $i = 0;
1702     while ($i < @{ $menu->{'entries'} })
1703     {
1704         my $entry = $menu->{'entries'}[$i];
1706         if ($entry->{type} eq 'menu' and remove_empty_menus($entry->{menu}))
1707         {
1708             splice @{ $menu->{'entries'} }, $i, 1;
1709         }
1710         else
1711         {
1712             $i++;
1713         }
1714     }
1716     @{ $menu->{'entries'} } == 0 ? return 1 : return 0;
1719 sub prepare_exec
1721     my ( $exec, $desktop ) = @_;
1723     # Take out filename flags, etc.
1724     $exec =~ s/%f//g;
1725     $exec =~ s/%F//g;
1726     $exec =~ s/%u//g;
1727     $exec =~ s/%U//g;
1728     $exec =~ s/%d//g;
1729     $exec =~ s/%D//g;
1730     $exec =~ s/%n//g;
1731     $exec =~ s/%N//g;
1732     $exec =~ s/%i//g;
1733     $exec =~ s/%k//g;
1734     $exec =~ s/%v//g;
1735     $exec =~ s/%m//g;
1737     my $caption = $desktop->{Name};
1738     $exec =~ s/%c/$caption/g;
1739     $exec =~ s/%%/%/g;
1741     if (defined $desktop->{Terminal})
1742     {
1743             if ($desktop->{Terminal} eq '1' or $desktop->{Terminal} eq 'true')
1744         {
1745                 $exec = "$TERM_CMD $exec";
1746             }
1747     }
1749     if (defined $desktop->{'X-KDE-SubstituteUID'})
1750     {
1751             if ($desktop->{'X-KDE-SubstituteUID'} eq '1'
1752                 or $desktop->{'X-KDE-SubstituteUID'} eq 'true')
1753         {
1754                 $exec = "$root_cmd $exec"
1755             }
1756     }
1757     return $exec;
1760 sub get_loc_entry
1762     my ( $desktop, $entry ) = @_;
1764     foreach my $key (@language_keys)
1765     {
1766         my $loc_entry = $entry . "[$key]";
1768         if (defined $desktop->{$loc_entry} and
1769             $desktop->{$loc_entry} !~ /^\s*$/)
1770         {
1771             return $desktop->{$loc_entry};
1772         }
1773     }
1775     return $desktop->{$entry};
1778 sub preprocess_menu
1780     # localize, sort, prepare_exec
1781     my ($menu) = @_;
1783     return 0 if $menu->{'Deleted'};
1784     return 0 unless check_show_in( $menu->{'Directory'} );
1786         if( defined $menu->{'Directory'} and
1787         defined $menu->{'Directory'}->{'NoDisplay'} and
1788         $menu->{'Directory'}->{'NoDisplay'} eq 'true')
1789     {
1790         return 0;
1791     }
1793     my $menu_name = $menu->{'Name'};
1794     if (defined $menu->{'Directory'})
1795     {
1796         my $directory = $menu->{'Directory'};
1797         my $directory_name = get_loc_entry( $directory, 'Name' );
1799         if (defined $directory_name)
1800         {
1801               if( !defined $directory->{"Encoding"} or
1802                   $directory->{"Encoding"} eq 'UTF-8')
1803               {
1804                   Encode::from_to($directory_name, "utf8", $charset);
1805               }
1807               $menu_name = $directory_name;
1808         }
1809     }
1811     $menu->{'PrepName'} = $menu_name;
1813     my $i = 0;
1814     while ( defined $menu->{'entries'}[$i] )
1815     {
1816         my $entry = $menu->{'entries'}[$i];
1817         if ( $entry->{'type'} eq 'desktop' )
1818         {
1819             my $desktop = $entry->{desktop};
1820             my $name = $desktop->{'id'};
1821             my $desktop_name = get_loc_entry( $desktop, 'Name' );
1822             if ( defined $desktop_name )
1823             {
1824                 Encode::from_to( $desktop_name, "utf8", $charset )
1825                   if !defined $desktop->{"Encoding"}
1826                       || $desktop->{"Encoding"} eq 'UTF-8';
1827                 $name = $desktop_name;
1828             }
1829             $desktop->{'PrepName'} = $name;
1830             $entry->{'Name'}       = $name;
1831             $entry->{'PrepName'}   = $name;
1832             $desktop->{'PrepExec'} = prepare_exec( $desktop->{Exec}, $desktop );
1833             $i++;
1834         }
1835         elsif ( $entry->{type} eq 'menu' )
1836         {
1837             if ( preprocess_menu( $entry->{'menu'} ) )
1838             {
1839                 $entry->{'Name'}     = $entry->{'menu'}{'Name'};
1840                 $entry->{'PrepName'} = $entry->{'menu'}{'PrepName'};
1841                 $i++;
1842             }
1843             else
1844             {
1845                 splice @{ $menu->{'entries'} }, $i, 1;
1846             }
1847         }
1848         else
1849         {
1850             warn "wrong menu entry type: $entry->{type}";
1851             exit 1 if $die_on_error;
1852             splice @{ $menu->{'entries'} }, $i, 1;
1853         }
1854     }
1856     $menu->{'entries'} = [
1857         sort {
1858             $b->{'type'} cmp $a->{'type'}
1859               || $a->{'PrepName'} cmp $b->{'PrepName'}
1860           } @{ $menu->{'entries'} }
1861     ];
1863     $i = 0;
1864     my $prev_entry;
1865     while ( defined $menu->{'entries'}[$i] )
1866     {
1867         my $entry = $menu->{'entries'}[$i];
1868         if (defined $prev_entry
1869             and $entry->{'type'}                       eq 'desktop'
1870             and $prev_entry->{'type'}                  eq 'desktop'
1871             and $prev_entry->{'PrepName'}              eq $entry->{'PrepName'}
1872             and $prev_entry->{'desktop'}->{'PrepExec'} eq
1873             $entry->{'desktop'}->{'PrepExec'} )
1874         {
1875             splice @{ $menu->{'entries'} }, $i, 1;
1876         }
1877         else
1878         {
1879             $prev_entry = $entry;
1880             $i++;
1881         }
1882     }
1883     return 1;
1886 sub output_fvwm2_menu
1888     my ($menu, $toplevel, $path) = @_;
1890     $path = '' unless defined $path;
1891     $toplevel = 1 unless defined $toplevel;
1893     my $output = '';
1894     my $label = '';
1895     my $menu_name = $menu->{'PrepName'};
1896     my $menu_id = "$path-" . $menu->{'Name'};
1897     $menu_id =~ s/\s/_/g;
1898     $menu_id = $menu_prefix if $toplevel;
1899     foreach my $entry ( @{ $menu->{'entries'} } )
1900     {
1901         if ( $entry->{type} eq 'menu' ) {
1902             $output .= output_fvwm2_menu( $entry->{'menu'}, 0, $menu_id );
1903         }
1904     }
1905     $output .= "DestroyMenu \"$menu_id\"\n";
1906     $output .= "AddToMenu \"$menu_id\" \"$dmicon{'fvwm_title'}$label$menu_name\" Title\n";
1908     if ($MENU_STYLE ne '')
1909     {
1910             push @menus_for_style, $menu_id;
1911     }
1913     foreach my $entry ( @{ $menu->{'entries'} } )
1914     {
1915         if ( $entry->{type} eq 'desktop' )
1916         {
1917             my $desktop = $entry->{desktop};
1918             my $name = $desktop->{'PrepName'};
1919             my $exec = $desktop->{'PrepExec'};
1920             $output .= "+                \"$dmicon{'fvwm_app'}$name\" Exec $exec\n";
1921         }
1922         elsif ( $entry->{type} eq 'menu')
1923         {
1924             my $name = $entry->{'menu'}{'PrepName'};
1925             my $id   = "$menu_id-" . $entry->{'menu'}{'Name'};
1926             $id =~ s/\s/_/g;
1927             $output .= "+                \"$dmicon{'fvwm_folder'}$name\" Popup \"$id\"\n";
1928         }
1929         else 
1930         {
1931             warn "wrong menu entry type: $entry->{type}";
1932         }
1933     }
1935     $output .= "\n";
1936     if ("$menu_id" eq "$menu_prefix-System_Tools")
1937     {
1938             $output .= "AddToMenu \"$menu_prefix-System_Tools\" " .
1939                 "\"$dmicon{'fvwm_app'}Regenerate Applications Menu\" " .
1940                 "FvwmForm FvwmForm-Desktop\n";
1941     }
1942     return $output;
1945 sub get_root_menu
1947     my $menu_base='applications';
1948     # fixme, change more...    $menu_base='settings';
1949     foreach my $dir ( split( /:/, $xdg_config_dirs ), "/etc/xdg" )
1950     {
1951         check_file("$dir/menus/$menu_base.menu");
1952         if ( -f "$dir/menus/$menu_base.menu" ) {
1953             warn "Root Menu $dir/menus/applications.menu\n" if $verbose;
1954             return "$dir/menus/$menu_base.menu";
1955         }
1956     }
1957     return "";
1960 sub get_app_dirs
1962     my %used;
1963     my $ret = '';
1965     return $ret unless check_app("kde-config");
1967     my @kde_xdgdata = split( /:/, `kde-config --path xdgdata-apps` );
1969     foreach (@kde_xdgdata)
1970     {
1971         s/\/applications\/*\s*$//;
1972     }
1974     foreach my $d (split( /:/, $xdg_data_dirs ),
1975         @kde_xdgdata, "/usr/share", "/opt/gnome/share")
1976     {
1977         my $dir = $d;
1978         $dir =~ s/\/*$//;
1979         next if defined $used{$dir};
1980         next if check_file("$dir/applications") ne 'D';
1981         $ret .= ':' if $ret ne '';
1982         $ret .= "$dir/applications";
1983         $used{$dir} = 1;
1984     }
1985     if ($verbose)
1986     {
1987         foreach ( split( ':', $ret ) )
1988         {
1989             warn "app dirs $_\n";
1990         }
1991     }
1992     return $ret;
1995 sub get_desktop_dirs
1997     my %used;
1998     my $ret = '';
1999     foreach my $dir ( split( /:/, $xdg_data_dirs ),
2000         qw(/usr/share /opt/kde3/share /opt/gnome/share) )
2001     {
2002         next if defined $used{$dir};
2003         next if check_file("$dir/desktop-directories") ne 'D';
2004         $ret .= ':' if $ret ne '';
2005         $ret .= "$dir/desktop-directories";
2006         $used{$dir} = 1;
2007     }
2008     warn "desktop dirs $ret\n" if $verbose;
2009     return $ret;
2012 sub get_KDE_legacy_dirs
2014     my %used;
2015     my @ret = ();
2016     my @legacy_dirs = (qw(
2017         /etc/opt/kde3/share/applnk
2018         /opt/kde3/share/applnk
2019         )
2020     );
2022     if (check_app("kde-config"))
2023     {
2024         push @legacy_dirs, reverse(split(/:/,`kde-config --path apps` ));
2025     }
2027     foreach my $d ( @legacy_dirs )
2028     {
2029         my $dir = $d;
2030         chomp $dir;
2031         $dir =~ s/\/*$//;
2032         next if defined $used{$dir};
2033         next if check_file("$dir") ne 'D';
2034         $used{$dir} = 1;
2035         push @ret, $dir;
2036     }
2037     warn "KDE legacy dirs @ret\n" if $verbose;
2038     return @ret;
2041 sub prepare_language_keys
2043     my ($language) = @_;
2045     my @keys;
2046     $language =~ s/\.[^@]*//;    # remove .ENCODING
2048     if ( $language =~ /^([^_]*)_([^@]*)@(.*)$/)
2049     {
2050         # LANG_COUNTRY@MODIFIER
2051         push @keys, $1 . '_' . $2 . '@' . $3;
2052         push @keys, $1 . '_' . $2;
2053         push @keys, $1 . '@' . $3;
2054         push @keys, $1;
2055     }
2056     elsif ($language =~ /^([^_]*)_([^@]*)$/)
2057     {
2058         # LANG_COUNTRY
2059         push @keys, $1 . '_' . $2;
2060         push @keys, $1;
2061     }
2062     elsif ($language =~ /^([^_]*)@(.*)$/)
2063     {
2064         # LANG@MODIFIER
2065         push @keys, $1 . '@' . $2;
2066         push @keys, $1;
2067     }
2068     elsif ($language =~ /^([^_@]*)$/)
2069     {
2070         # LANG
2071         push @keys, $1;
2072     }
2074     return @keys;
2077 # Fixme, remove unsupported options.
2078 sub show_help
2080         print <<END_HELP;
2081 A perl script which parses xdg menu definitions to build
2082 the corresponding fvwm menus.  The script can also build
2083 Icon and MiniIcon styles for the desktop applications.
2085 Usage: $0 [OPTIONS]
2086 Options:
2087         --help                    show this help and exit
2088         --version                 show version and exit
2089         --install-prefix DIR      install prefix of the desktop
2090         --desktop NAME            desktop to build the menu for it:
2091                 gnome-sys (default), gnome-user, gnome-redhat, gnome-madriva,
2092                 kde-sys, kde-user
2093         --type NAME               fvwm (default) or gtk for a FvwmGtk menu
2094         --fvwmgtk-alias NAME      FvwmGtk module name, default is FvwmGtk
2095         --title NAME              menu title, default depends on --desktop
2096         --name NAME               menu name, default depends on --desktop
2097         --merge-user-menu         merge the system menu with the user menu
2098         --enable-mini-icons       enable mini-icons in menu
2099         --enable-tran-mini-icons  enable mini-icons in menu and
2100                 translation of foo.png icon names to foo.xpm
2101         --mini-icons-path DIR     path of menus icons (relative to your
2102                 ImagePath), default is 'mini/'
2103         --png-icons-path DIR      path of .png icons, default is your ImagePath
2104         --tran-mini-icons-path DIR      path of menus icons for translation
2105         --check-mini-icons PATH   check if the mini icons are in PATH
2106         --icon-toptitle micon:law:place:sidepic:color  mini-icon for the top
2107                  title and sidepic for the top menu
2108         --icon-title micon:law:place:sidepic:color     as above for sub menus
2109         --icon-folder micon:law:place   mini-icons for folder item
2110         --icon-app micon:law:place      mini-icon for applications item
2111         --wm-icons                define menu icon names to use with wm-icons
2112         --enable-style            build icons and mini-icons style
2113         --enable-tran-style       as above with translation (for FvwmGtk menus)
2114         --icon-style micon:icon:law     icons for style
2115         --icons-path DIR          define the directory of the icons,
2116                 the default is very good
2117         --tran-icons-path DIR     similar to the above option.
2118         --check-icons PATH        check if the icons are in the PATH
2119         --submenu-name-prefix NAME      in general not useful
2120         --dir DIR                 use path as desktop menu description
2121         --destroy-type FLAG       how to destroy menu, valid values:
2122                 'yes', 'no', 'dynamic', the default depends on --type
2123         --xterm CMD               complete terminal command to run applications
2124                 in it, default is 'xterm -e'
2125         --lang NAME               language, default is \$LANG
2126         --utf8                    For desktop entries coded in UTF-8 (KDE2)
2127         --uniconv                 Use (un)iconv for UTF-8 translation
2128         --uniconv-exec            uniconv or iconv (default)
2129         --menu-style name         assign specified MenuStyle name to menus
2130         --[no]check-app           [do not] check that apps are in your path
2131         --time-limit NUM          limit script running time to NUM seconds
2132         --verbose                 display debug type info oni STDERR
2133 Short options are ok if not ambiguous: -h, -x, -icon-a.
2134 END_HELP
2135         exit 0;
2138 # Check if application binary is executable and reachable
2139 sub check_app
2141         my($app) = @_;
2142         # If full path, dont use path, just check path
2143         if ( substr($app,0,1) eq '/' and -x $app )
2144     {
2145         return 1;
2146     }
2148         # Check if an application is in the path
2149         foreach (@PATH_DIRS)
2150     {
2151                 return 1 if -x "$_/$app";
2152         }
2154         return 0;
2157 sub show_version
2159         print "$version\n";
2160         exit 0;
2163 sub obsolete
2165     my ($arg) = @_;
2166     print "WARNING: Argument \"$arg\" obsolete.  Ignored.\n";
2168 # Local Variables:
2169 # compile-command: "perl fvwm-menu-desktop.in --enable-mini-icons --fvwm-icons"
2170 # End: