← Back to branch summary

~ubuntu-branches/ubuntu/natty/perl-tk/natty

« back to all changes in this revision

Viewing changes to Tk/FileSelect.pm

  • Committer: Bazaar Package Importer
  • Author(s): Stephen Zander
  • Date: 2004-03-14 13:54:44 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20040314135444-prc09u2or4dbr3to
Tags: 1:800.025-2
http://bugs.debian.org/237942
Add xlibs-dev to Build-Depends:,
Closes: #237942

Show diffs side-by-side

added added

removed removed

Lines of Context:
Tk/FileSelect.pm
1
1
package Tk::FileSelect;
2
2
 
3
3
use vars qw($VERSION @EXPORT_OK);
4
 
$VERSION = '3.047'; # $Id: //depot/Tk8/Tk/FileSelect.pm#47 $
 
4
$VERSION = '3.050'; # $Id: //depot/Tk8/Tk/FileSelect.pm#50 $
5
5
@EXPORT_OK = qw(glob_to_re);
6
6
 
7
7
use Tk qw(Ev);
177
177
    );
178
178
    $e->pack(-side => 'bottom', -expand => 0, -fill => 'x');
179
179
    $e->bind('<Return>' => [$w => 'validateFile', Ev(['get'])]);
 
180
    $e->bind('<FocusIn>' => [$w => 'SelectionClear']);
180
181
 
181
182
    # Create directory scrollbox, place at the left-middle.
182
183
    my $b = $w->Component(
337
338
    {
338
339
     if (substr($dir,1,1) eq '/')
339
340
      {
340
 
       $dir = $ENV{'HOME'} . substr($dir,1);
 
341
       $dir = (defined $ENV{'HOME'} ? $ENV{'HOME'} : '') . substr($dir,1);
341
342
      }
342
343
     else
343
344
      {my ($uid,$rest) = ($dir =~ m#^~([^/]+)(/.*$)#);
344
345
       $dir = (getpwnam($uid))[7] . $rest;
345
346
      }
346
347
    }
 
348
   my $revert_dir = sub
 
349
    {
 
350
     my $message = shift;
 
351
     $$var = $cw->{OldDirectory};
 
352
     $cw->messageBox(-message => $message, -icon => 'error');
 
353
     if (!defined $$var)
 
354
      {
 
355
       # OldDirectory was never set, so force reread...
 
356
       $$var = $cw->{OldDirectory} = Cwd::getcwd(); # XXX maybe use check like code below...
 
357
       unless ($cw->{'reread'}++)
 
358
        {
 
359
         $cw->Busy;
 
360
         $cw->afterIdle(['reread',$cw])
 
361
        }
 
362
      }
 
363
     $$var;
 
364
    };
347
365
   $dir =~ s#([^/\\])[\\/]+$#$1#;
348
366
   if (-d $dir)
349
367
    {
359
377
          }
360
378
         else
361
379
          {
362
 
           carp "Cannot getcwd in '$dir'";
363
 
          }
364
 
         chdir($pwd) || carp "Cannot chdir($pwd) : $!";
365
 
         $cw->{Configure}{'-directory'} = $dir;
 
380
           return $revert_dir->("Cannot getcwd in '$dir'");
 
381
          }
 
382
         if (!chdir($pwd))
 
383
          {
 
384
           return $revert_dir->("Cannot change directory to $pwd:\n$!");
 
385
          }
 
386
         $$var = $dir;
366
387
        }
367
388
       else
368
389
        {
369
 
         $cw->BackTrace("Cannot chdir($dir) :$!");
 
390
         return $revert_dir->("Cannot change directory to $dir:\n$!");
370
391
        }
 
392
       $$var = $cw->{OldDirectory} = $dir;
371
393
      }
372
 
     $$var = $dir;
373
394
     unless ($cw->{'reread'}++)
374
395
      {
375
396
       $cw->Busy;
431
452
       $w->configure(-initialfile => undef) unless $w->cget('-create');
432
453
      }
433
454
    }
434
 
   $w->{DirectoryString} = $dir . '/' . $w->cget('-filter');
 
455
   $w->{DirectoryString} = $dir . ($dir ne '/' ? '/' : '') . $w->cget('-filter');
435
456
  }
436
457
 $w->{'reread'} = 0;
437
 
 $w->Unbusy;
 
458
 $w->Unbusy if $w->{'Busy'};
438
459
}
439
460
 
440
461
sub validateDir