Advertisement
Guest User

Untitled

a guest
Mar 11th, 2018
115
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 10.06 KB | None | 0 0
  1. #!/usr/bin/perl
  2.  
  3. # Copyright (C) 2012-2016 Daniel "Trizen" Șuteu <echo dHJpemVueEBnbWFpbC5jb20K | base64 -d>.
  4. #
  5. # This program is free software: you can redistribute it and/or modify
  6. # it under the terms of the GNU General Public License as published by
  7. # the Free Software Foundation, either version 3 of the License, or
  8. # (at your option) any later version.
  9. #
  10. # This program is distributed in the hope that it will be useful,
  11. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  13. # GNU General Public License for more details.
  14. #
  15. # You should have received a copy of the GNU General Public License
  16. # along with this program. If not, see <http://www.gnu.org/licenses/>.
  17.  
  18. # Original author: dircha
  19. # See: http://bbs.archbang.org/viewtopic.php?id=1589
  20.  
  21. # License: GPLv3
  22. # Date: 29 December 2012
  23. # Latest edit: 04 May 2016
  24. # Website: http://github.com/trizen/obbrowser
  25.  
  26. # ---------------------------------------------------------
  27. # Recursively browse filesystem through openbox3 pipe menus
  28. # ---------------------------------------------------------
  29.  
  30. #use 5.014;
  31. #use strict;
  32. #use warnings;
  33.  
  34. my $pkgname = 'obbrowser';
  35. my $version = 0.06;
  36.  
  37. our $CONFIG;
  38.  
  39. my $home_dir =
  40. $ENV{HOME}
  41. || $ENV{LOGDIR}
  42. || (getpwuid($<))[7]
  43. || `echo -n ~`;
  44.  
  45. my $config_dir = "$home_dir/.config/obbrowser";
  46. my $config_file = "$config_dir/config.pl";
  47. my $icons_db_filename = "$config_dir/icons.db";
  48.  
  49. if (not -d $config_dir) {
  50. require File::Path;
  51. File::Path::make_path($config_dir)
  52. or die "Can't create dir `$config_dir': $!";
  53. }
  54.  
  55. sub print_usage {
  56. print <<"USAGE";
  57. usage: $0 [dir]
  58.  
  59. 1. To use this script with Openbox, insert the following
  60. line in ~/.config/openbox/menu.xml:
  61.  
  62. <menu id="obbrowser" label="Disk" execute="$0"/>
  63.  
  64. 2. If "obmenu-generator" is used for generating the Openbox menu,
  65. insert the following line in ~/.config/obmenu-generator/schema.pl:
  66.  
  67. {pipe => ["obbrowser", "Disk", "drive-harddisk"]},
  68.  
  69. 3. For more settings, check out the configuration file:
  70.  
  71. $config_file
  72.  
  73. 4. After changing the current icon theme, also delete the icon database
  74. that is generated by obbrowser:
  75.  
  76. $icons_db_filename
  77.  
  78. USAGE
  79. exit;
  80. }
  81.  
  82. if (@ARGV and $ARGV[0] eq '-h' || $ARGV[0] eq '--help') {
  83. print_usage();
  84. }
  85.  
  86. my $config_documentation = <<"EOD";
  87. #!/usr/bin/perl
  88.  
  89. # $pkgname - configuration file
  90. # This file is updated automatically.
  91. # Any additional comment and/or indentation will be lost.
  92.  
  93. =for comment
  94.  
  95. || ICON SETTINGS
  96. | icon_dirs_first : While searching for icons, look in this directories first,
  97. before looking in the directories of the current icon theme.
  98. Example: [
  99. "\$ENV{HOME}/My icons",
  100. ],
  101.  
  102. | icon_dirs_last : While searching for icons, also look in this icon directories.
  103. Example: [
  104. "/usr/share/icons/Tango",
  105. ],
  106.  
  107. | with_icons : A true value will make the script to use icons for files and directories.
  108. This option may be slow, depending on the configuration of your system.
  109.  
  110. | mime_ext_only : A true value will make the script to get the mimetype by extension only.
  111. This will improve the performance, as no content will be read from files.
  112.  
  113. | gtk_rc_filename : Absolute path to the gtkrc file.
  114. This file is used to get the name of the current icon theme.
  115.  
  116.  
  117. || MENU
  118. | file_manager : Command to your file manager for opening files and directories.
  119. | browse_label : Label for browse here action.
  120. | start_path : An absolute path from which to start to browse the filesystem.
  121. | dirs_first : A true value will make the script to order directories before files.
  122.  
  123. =cut
  124.  
  125. EOD
  126.  
  127. my %CONFIG = (
  128. 'Linux::DesktopFiles' => {
  129. gtk_rc_filename => "$home_dir/.gtkrc-2.0",
  130. icon_dirs_first => undef,
  131. icon_dirs_last => undef,
  132. skip_svg_icons => 0,
  133. },
  134. file_manager => 'pcmanfm',
  135. browse_label => 'Browse here...',
  136. start_path => $home_dir,
  137. dirs_first => 0,
  138. with_icons => 1,
  139. mime_ext_only => 0,
  140. VERSION => $version,
  141. );
  142.  
  143. sub dump_configuration {
  144. require Data::Dump;
  145. open my $config_fh, '>', $config_file
  146. or die "Can't open file '${config_file}' for write: $!";
  147. my $dumped_config = q{our $CONFIG = } . Data::Dump::dump(\%CONFIG);
  148. print $config_fh $config_documentation, $dumped_config;
  149. close $config_fh;
  150. }
  151.  
  152. if (not -e $config_file or -z _) {
  153. dump_configuration();
  154. }
  155.  
  156. require $config_file; # load the configuration file
  157.  
  158. my @valid_keys = grep exists $CONFIG{$_}, keys %{$CONFIG};
  159. @CONFIG{@valid_keys} = @{$CONFIG}{@valid_keys};
  160.  
  161. if ($CONFIG{VERSION} != $version) {
  162. $CONFIG{VERSION} = $version;
  163. dump_configuration();
  164. }
  165.  
  166. my $ld_obj;
  167. if ($CONFIG{with_icons}) {
  168.  
  169. my @keys = qw(
  170. Tie/Hash.pm
  171. Carp.pm
  172. Exporter.pm
  173. warnings.pm
  174. );
  175.  
  176. @INC{@keys, 'warnings/register.pm', 'strict.pm'} = ();
  177.  
  178. require Linux::DesktopFiles;
  179.  
  180. $Linux::DesktopFiles::VERSION >= 0.08
  181. || die "Update Linux::DesktopFiles to a newer version! (requires >=0.08)\n";
  182.  
  183. $ld_obj = Linux::DesktopFiles->new(
  184. %{$CONFIG{'Linux::DesktopFiles'}},
  185.  
  186. strict_icon_dirs => 1,
  187. use_current_theme_icons => 1,
  188. home_dir => $home_dir,
  189.  
  190. $CONFIG{with_icons}
  191. ? (
  192. abs_icon_paths => 1,
  193. icon_db_filename => $icons_db_filename,
  194. )
  195. : (),
  196. );
  197.  
  198. delete @INC{@keys};
  199. }
  200.  
  201. {
  202. my %table = (
  203. '&' => 'amp',
  204. '"' => 'quot',
  205. "'" => 'apos',
  206. '<' => 'lt',
  207. '>' => 'gt',
  208. );
  209.  
  210. sub xmlEscape {
  211. $_[0] =~ tr/&"'<>// ? $_[0] =~ s/([&"'<>])/&$table{$1};/gr : $_[0];
  212. }
  213. }
  214.  
  215. sub escapeQuot {
  216. index($_[0], '&quot;') == -1 ? $_[0] : $_[0] =~ s/&quot;/\\&quot;/gr;
  217. }
  218.  
  219. sub mk_dir_elem {
  220. qq{<menu id="$_[0]/$_[2]" label="}
  221. . ($_[2] =~ s/_/__/gr)
  222. . qq{" icon="$_[3]" execute="$_[4] &quot;$_[1]/}
  223. . escapeQuot($_[2])
  224. . q{&quot;"/>};
  225. }
  226.  
  227. sub mk_file_elem {
  228. qq{<item label="}
  229. . ($_[2] =~ s/_/__/gr)
  230. . qq{" icon="$_[3]"><action name="Execute"><execute>$CONFIG{file_manager} &quot;$_[1]/}
  231. . escapeQuot($_[2])
  232. . q{&quot;</execute></action></item>};
  233. }
  234.  
  235. {
  236. my $path = @ARGV ? shift() : $CONFIG{start_path};
  237.  
  238. my (%alias, %icons, @dirs, @files);
  239. opendir(my $dir_h, $path) or warn "$0: Can't open dir `$path': $!\n";
  240. foreach my $file (readdir $dir_h) {
  241.  
  242. next if chr ord $file eq q{.}; # skip the hidden files
  243.  
  244. if ($CONFIG{with_icons}) {
  245.  
  246. if (-d "$path/$file") {
  247. push @dirs, [$file, $icons{'inode-directory'} ||= $ld_obj->get_icon_path('inode-directory')];
  248. next;
  249. }
  250.  
  251. require File::MimeInfo; # File::MimeInfo::Magic is better, but slower!
  252.  
  253. my $mime_type = (
  254. (
  255. $CONFIG{mime_ext_only}
  256. ? File::MimeInfo::globs($file)
  257. : File::MimeInfo::mimetype("$path/$file")
  258. ) // 'unknown'
  259. ) =~ tr{/}{-}r;
  260.  
  261. $mime_type = $alias{$mime_type} if exists $alias{$mime_type};
  262.  
  263. {
  264. my $type = $mime_type;
  265. while (1) {
  266. if ($icons{$type} ||= $ld_obj->get_icon_path($type)) {
  267. $alias{$mime_type} = $type;
  268. $mime_type = $type;
  269. last;
  270. }
  271. elsif ($icons{"gnome-mime-$type"} ||= $ld_obj->get_icon_path("gnome-mime-$type")) {
  272. $alias{$mime_type} = "gnome-mime-$type";
  273. $mime_type = "gnome-mime-$type";
  274. last;
  275. }
  276. $type =~ s{.*\K[[:punct:]]\w++$}{} || last;
  277. }
  278. }
  279.  
  280. if (!$icons{$mime_type}) {
  281. my $type = $mime_type;
  282. while (1) {
  283. $type =~ s{^application-x-\K.*?-}{} || last;
  284. $icons{$type} ||= $ld_obj->get_icon_path($type);
  285. $icons{$type} && do { $alias{$mime_type} = $type; $mime_type = $type; last };
  286. }
  287. }
  288. push @files, [
  289. $file, $icons{$mime_type} ||=
  290. do { $alias{$mime_type} = 'unknown'; $ld_obj->get_icon_path('unknown') }
  291. ];
  292. }
  293. else {
  294. push @{-d "$path/$file" ? \@dirs : \@files}, [$file, ''];
  295. }
  296.  
  297. }
  298. closedir $dir_h;
  299.  
  300. my $thisDir = xmlEscape($path);
  301. my $qEscapedDir = escapeQuot($thisDir);
  302. my $escapedProgramName = xmlEscape($0);
  303.  
  304. # "Browse here..." launches this directory
  305. my $generated_menu = qq{<openbox_pipe_menu><item label="$CONFIG{browse_label}"><action name="Execute">}
  306. . qq{<execute>$CONFIG{file_manager} &quot;$qEscapedDir&quot;</execute></action></item><separator/>};
  307.  
  308. my @calls = ([\&mk_file_elem => \@files], [\&mk_dir_elem => \@dirs]);
  309.  
  310. foreach my $call ($CONFIG{dirs_first} ? reverse(@calls) : @calls) {
  311. $generated_menu .= $call->[0]->($thisDir, $qEscapedDir, xmlEscape($_->[0]), $_->[1], $escapedProgramName)
  312. for sort { lc $a->[0] cmp lc $b->[0] } @{$call->[1]};
  313. }
  314.  
  315. ++$|;
  316. print $generated_menu, "</openbox_pipe_menu>";
  317. exit;
  318. }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement