← Back to branch summary

~ubuntu-branches/ubuntu/maverick/perl-tk/maverick

« back to all changes in this revision

Viewing changes to pfm

  • Committer: Bazaar Package Importer
  • Author(s): Colin Tuckley
  • Date: 2010-05-30 09:19:40 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20100530091940-wbmq9bloo92t9m6x
Tags: 1:804.029-1
http://bugs.debian.org/578814
* New Upstream Release (Closes: #578814).
* Added debian/watch file.

Show diffs side-by-side

added added

removed removed

Lines of Context:
pfm
1
 
#!/usr/local/bin/perl -w
2
 
use POSIX qw(getcwd);
3
 
 
4
 
use Tk;
5
 
# use Tk::ErrorDialog;
6
 
use Tk::DragDrop qw(Sun);
7
 
require Tk::Tiler;
8
 
 
9
 
{package Dragable;
10
 
 require Tk::Label;
11
 
 use Tk qw(Ev);
12
 
use base  qw(Tk::Label);
13
 
 Construct Tk::Widget Dragable;
14
 
 
15
 
 sub ClassInit
16
 
 {
17
 
  my ($class,$mw) = @_;
18
 
  $mw->bind($class,'<FocusIn>','Bell');
19
 
  return $class;
20
 
 }
21
 
 
22
 
 sub LabelInfo
23
 
 {
24
 
  my $w = shift;
25
 
  my @config = ();
26
 
  my $option;
27
 
  foreach $option ($w->configure())
28
 
   {
29
 
    next if (@$option == 2 || !defined $$option[4]);
30
 
    next if (defined $$option[3] && $$option[3] eq $$option[4]);
31
 
    push(@config,$$option[0],$$option[4]);
32
 
   }
33
 
  return (@config);
34
 
 }
35
 
 
36
 
 sub new
37
 
  {my $class  = shift;
38
 
   my $parent = shift;
39
 
   my $obj = $parent->Label(@_,-takefocus => 1);
40
 
   # $obj->bind('<B1-Motion>',['DragDrop',Ev(['LabelInfo'])]);
41
 
   return bless $obj,$class;
42
 
  }
43
 
 
44
 
}
45
 
 
46
 
$icon_dir = Tk->findINC("demos/images");
47
 
 
48
 
%icons = ();
49
 
 
50
 
sub Edit
51
 
{
52
 
 my $w = shift;
53
 
 my $path = shift;
54
 
 if (-T $path)
55
 
  {
56
 
   fork || exec("$ENV{EDITOR} $path");
57
 
  }
58
 
}
59
 
 
60
 
sub choose_icon
61
 
{
62
 
 my $w    = shift;
63
 
 my $name = shift;
64
 
 my $icon = (-d $name) ? "dir" : ($name =~ /\.([^\.]+)$/) ? $1 : "page";
65
 
 if (!defined $icons{$icon})
66
 
  {
67
 
   my $file = "$icon_dir/$icon.xpm";
68
 
   if (-f "$file")
69
 
    {
70
 
     $icons{$icon} = $w->Pixmap($icon,-file=>"$file");
71
 
    }
72
 
   else
73
 
    {
74
 
     my $file = "$icon_dir/$icon.icon";
75
 
     my $mask = "$icon_dir/$icon.mask";
76
 
     $file = "$icon_dir/page.icon" unless (-f $file);
77
 
     $mask = "$icon_dir/page.mask" unless (-f $mask);
78
 
     $icons{$icon} = $w->Bitmap($icon,-file=> $file,-maskfile=>$mask);
79
 
    }
80
 
   if ($icons{$icon}->width != 32)
81
 
    {
82
 
     $icons{$icon} = choose_icon($w,"page");
83
 
    }
84
 
  }
85
 
 return $icons{$icon};
86
 
}
87
 
 
88
 
 
89
 
 
90
 
sub handle_string
91
 
{my ($string,$offset,$max) = @_;
92
 
 return $string;
93
 
}
94
 
 
95
 
sub do_dir
96
 
{
97
 
 my $w   = shift;
98
 
 my $dir = shift;
99
 
 opendir(DIR,$dir);
100
 
 my @files = readdir(DIR);
101
 
 closedir(DIR);
102
 
 my @windows = ();
103
 
 my $width  = 0;
104
 
 my $height = 0;
105
 
 my @win    = ();
106
 
 foreach (sort @files)
107
 
  {
108
 
   next if (/^\.*$/);
109
 
   my $path = "$dir/$_";
110
 
   my $f = $w->Frame();
111
 
   my $i = $f->Dragable(-image=> choose_icon($w,$path));
112
 
   $i->DragDrop(-image => $i->cget('-image'),-handlers => [[-type =>'FILE_NAME',[\&handle_string,"$dir/$_"]]]);
113
 
   my $l = $f->Label(-text=> $_);
114
 
   $i->bind('<FocusIn>','break');
115
 
   $i->pack(-side=>'top');
116
 
   $l->pack(-side=>'bottom',-fill=> 'x');
117
 
   if (-d $path)
118
 
    {
119
 
     $w->Manage($f);
120
 
    }
121
 
   else
122
 
    {
123
 
     $i->bind('<Double-1>',[\&Edit,$path]);
124
 
     push(@win,$f);
125
 
    }
126
 
  }
127
 
 $w->Manage(@win);
128
 
}
129
 
 
130
 
$dir = (@ARGV) ? shift : getcwd();
131
 
 
132
 
$top = MainWindow->new();
133
 
 
134
 
$t   = $top->Tiler();
135
 
$t->pack(-side=>'right',-fill=>'both',-expand=>1);
136
 
$top->AddScrollbars($t);
137
 
$top->configure('-scrollbars' => 'w');
138
 
do_dir($t,$dir);
139
 
 
140
 
$t->update;
141
 
 
142
 
$t->focus;
143
 
 
144
 
MainLoop;