#!perl

#  This is a modified copy of the directory explorer code posted on
#  PerlMonks by 'GrandFather' at ...
#
#  http://perlmonks.org/index.pl?node_id=535607
#  http://perlmonks.org/index.pl?displaytype=print;node_id=535607;replies=1

use warnings;
use strict;

use Tk;
use Tk::Tree;
use Tk::Font;

use File::Spec;

BEGIN
{
  #  Tk-related variable(s).
  our ( $node_sep ) = ( '/' );

  sub stack_as_string
  { return join $node_sep , ref $_[0] ? @{ $_[0] } : @_; }

  #  Number of bytes.
  my %units =
    (
      1                         => 'B'
    , 1024                      => 'KB'
    , 1024 * 1024               => 'MB'
    , 1024 * 1024 * 1024        => 'GB'
    , 1024 * 1024 * 1024 * 1024 => 'TB'
    ) ;
  my @ordered = sort { $a <=> $b } keys %units;
  #  Convert size in bytes to a unit (upto TB) appropriate for the order of
  #  the size.
  sub size_in_xbyte
  {
    my ( $size ) = @_;

    return 'UNKNOWN SIZE' unless defined $size;

    my $factor = $ordered[0];
    foreach my $u ( @ordered )
    {
      $size < $u and last;
      $factor = $u;
    }
    #  Use number of bytes (B) as is (knowing that $factor will be 1).
    my $format = $factor != $ordered[0] ? '%0.1f %s' : '%0d %s';
    return sprintf $format, $size / $factor, $units{$factor};
  }
}
our ( $node_sep );
my $tree_start = 1;

my $path = shift;
ShowHelp() unless defined $path;

#  In File::Spec pod, there is no constructor method noted, nor is 'simple
#  use' defined for which functional forms of methods are available.  Missing
#  also is a list of exported function.
my $fspec = 'File::Spec';

$path = $fspec->canonpath($path);
ShowHelp( -2 , "Error finding folder $path\n\n" ) unless -d $path;

my $main = MainWindow->new( '-title' => "Folder stats for $path" );
#  Adjust as you like.
$main->geometry( '900x700' );

my $tree =
  $main->ScrlTree
  ( '-font' => $main->Font( 'systemfont' )
  , '-itemtype'  => 'text'
  , '-separator' => $node_sep

    #  Once, having scrollbars-only-when-needed-option, 'o', did not make the
    #  scrollbars appear when the content overflows display area (FreeBSD
    #  6-STABLE & Tk-804.027, Tk 8.4.11.2). Now (Sun Mar 12 13:18:18 UTC 2006)
    #  optional scrollbars are behaving as advertised.  And i do not know
    #  why|how!
  , '-scrollbars' => 'osow'
  )
  ->pack( '-fill' => 'both' , '-expand' => 1 )
  ;

my @node_stack = ($tree_start);
my $node = $tree_start;
$tree->add( $node , '-text' => $path );

my ( $subDirCount , $subFileCount , $subTotalSize ) =
  buildSubTree( $tree , $path , \@node_stack );

$tree->entryconfigure
( $node
, '-text' => annotate( $path , $subTotalSize , $subDirCount , $subFileCount )
);

$tree->autosetmode;
collapse_nodes( $tree );
$tree->open( $node );

$main->bind( '<KeyPress-q>' , sub { exit ; } );
$tree->bind( '<KeyPress-Return>' , \&toggle_tree_expand );

$tree->focus;

MainLoop;

#  Key binding function to expand|collapse a subtree.
sub toggle_tree_expand
{
  my $root = $tree->info( 'selection' );
  return unless defined $root && length $root;

  my @nodes = $tree->info( 'children' , $root );
  return unless scalar @nodes;

  #  $tree->open() does not (sometimes) expands a tree, but $tree->close() does
  #  collapse an open()'d tree.
  #  --
  #  Handle both open & close cases for now.
  my ( $meth );
  foreach ( @nodes )
  {
    $meth = $tree->info( 'hidden' , $nodes[-1] ) ? 'show' : 'hide';
    $tree->setmode( $root , $meth eq 'show' ? 'close' : 'open' );
    $tree->$meth( 'entry' , $_ );
  }
  $tree->update;
}

sub collapse_nodes
{
  my ( $tree , $node , $collapse ) = @_;

  my @subnodes = $tree->info( 'children' , $node );
  return unless scalar @subnodes;

  foreach my $n ( @subnodes )
  {
    collapse_nodes( $tree , $n , 1 );
    $tree->hide( 'entry' , $n ) if $collapse;
  }
  $tree->setmode( $node , 'open' ) if $node;
}

sub buildSubTree
{
  my ( $tree , $path , $stack ) = @_ ;

  my ( $dirCount , $fileCount , $sizeTotal ) = (0) x3 ;

  push @$stack , $tree_start;

  opendir my $DH , $path or die "Cannot open $path: $!\n";
  foreach my $dir ( sort readdir $DH )
  {
    next if $dir eq $fspec->updir or $dir eq $fspec->curdir;

    #  Don't know what will happen if catfile() is substitued w/ catdir()
    #  on non-Unix operating systems.
    my $path = $fspec->catfile( $path , $dir );

    my $node = stack_as_string( $stack );
    $tree->add( $node , '-text' => $path );

    my ( $size , $dirs , $files );
    #  Use lstat to avoid chasing circular|dangling symbolic links.
    lstat $path;
    if ( ! -d _ )
    {
      ++$fileCount;
      $size = -s _;
      $sizeTotal += $size if defined $size;
    }
    else
    {
      ( $dirs , $files , $size ) = buildSubTree( $tree , $path , $stack );
      $dirCount  += $dirs + 1;
      $fileCount += $files;
      $sizeTotal += $size;

    }
    $tree->entryconfigure
    ( $node , '-text' => annotate( $path , $size , $dirs , $files ) );

    ++$stack->[-1];
  }
  closedir $DH or die "Cannot close $path: $!\n";
  pop @$stack;

  return ( $dirCount , $fileCount , $sizeTotal );
}

sub annotate
{
  my ( $path , $size , $dirs , $files ) = @_;
  return
    join q//
    , $path
    , "\t("
    , size_in_xbyte( $size )
    , ( map
        { !$_->[0]
          ? ()
          : sprintf ', %s %s%s' , @{$_} , count_to_plural_suffix( $_->[0] )
        }
          [ $dirs , 'dir' ] , [ $files , 'file' ]
      )
    , ')'
    ;
}

sub count_to_plural_suffix { return $_[0] > 1 ? 's' : ''; }

sub ShowHelp
{
  my $exitValue = 0;
  $exitValue = shift if defined $_[0] and $_[0] =~ /^[-+]?\d+$/;

  print $_ while $_ = shift;

  print <<HELP;
FolderStats scans a directory tree starting at the folder given on the
command line and generates an explorer like tree giving folder content
stats such as number of files, their total size, and the count and
sizes of sub-folders.

Note that the statistics are not dynamically updated as files and
folders are altered on disk.

Usage:

  FolderStats <root folder>

Key Binding:

            q: quits the program.

        Enter: expands or collapses a tree.

     Up, Down: Vertically move up or down.
       arrows:

  Left, Right: Move one level up or down.
       arrows:

HELP

  exit( $exitValue || -1 );
}