view release on metacpan or  search on metacpan

example/file.pl  view on Meta::CPAN

  # Usage:  quit();

  $rv = dialog('Quit Application?', BTN_YES | BTN_NO, 
    'Are you sure you want to quit?', qw(white red yellow));
  exit 0 unless ($rv);
}

sub loaddir {
  # Returns a sort list of list, with each sublist being a file
  # and its attributes.
  #
  # Usage:  @entries = loaddir($dir);

  my $dir = shift;
  my ($e, @rv);

  if (opendir(DIR, $dir)) {
    while (defined($e = readdir(DIR))) { push(@rv, $e) };
    closedir(DIR);
    @rv = map { [$_, sizer(-s "$dir/$_"), transmode("$dir/$_")] } 
      sort @rv;
  }

  return @rv;
}

sub sizer {
  # Massages the passed size to use the metric abbreviations.
  #
  # Usage:  $size = sizer($size);

  my $size = shift || 0;
  my @suffixes = qw(B K M G); # Bytes, Kilobytes, Megabytes, Gigabytes
  my $l = length($size);
  my $indx = 0;
  my $p;

  # Find the byte prefix
  while ($l > 3) {
    ++$indx;
    $l -= 3;
  }
  $size /= 1024 ** $indx if $indx > 0;

  # Find the sprintf argument
  if ($l >= 2) {
    $p = "\% 3d$suffixes[$indx]";
  } else {
    $p = "\%1.1f$suffixes[$indx]";
  }

  return sprintf($p, $size);
}

sub transmode {
  # Returns a string showing the entry permissions (a la ls -l)
  #
  # Usage:  $mode = transmode($file);

  my $file = shift;
  my $stat = (stat($file))[2];
  my $mode = defined $stat ? sprintf('%04o', $stat & 07777) : '0000';
  my @ebits = qw(r w x);
  my @bits = (4, 2, 1);
  my ($digit, $i, $rv);

  # Translate last three octets
  foreach $digit (split(//, substr($mode, 1))) {
    for ($i = 0; $i < @bits; $i++) {
      $rv .= $digit & $bits[$i] ? $ebits[$i] : '-';
    }
  }

  # Check if it's a link
  if (-l $file) {
    $rv = "l$rv";

  # Or a directory
  } elsif (-d _) {
    $rv = "d$rv";

  # Or a block device
  } elsif (-b _) {
    $rv = "b$rv";

  # Or a character device
  } elsif (-c _) {
    $rv = "c$rv";

  # Or a socket
  } elsif (-S _) {
    $rv = "s$rv";

  # Or a pipe
  } elsif (-p _) {
    $rv = "p$rv";

  } else {
    $rv = "-$rv";
  }

  # Check for sticky bits
  substr($rv, 3, 1) = 's' if -u _;
  substr($rv, 6, 1) = 's' if -g _;
  substr($rv, 9, 1) = 't' if -k _;

  return $rv;
}

sub chgdir {
  # Changes the current directory as per the selected entry in
  # the list box.
  #
  # Usage:  chgdir();

  my $w = shift;
  my ($pos, $items, $cwd, $caption) = 
    $w->getField(qw(CURSORPOS LISTITEMS CWD CAPTION));

  return if $$items[$pos][0] eq '.';