#!/usr/bin/perl -w

######################################################################
###
###   IMPORTANT!
###   Please read the warranty and legal notice 
###   at the end of this file!
###
######################################################################

require 5.000;
use lib '/usr/local/bin',"$ENV{HOME}/bin",'/usr/stud/loescher/bin';
use lib 'd:/bin','c:/mydos','c:/bin';
use slutil;
use English;
use Tk;

######################################################################
### Voreinstellungen
######################################################################

$appname = 'XDirUsage';
$version = '1.15';
$geometry = '500x1024+100+0';

@colors = qw(
blue1 red1 yellow1 purple1 green1 cyan1 gold1 magenta1 
IndianRed1 SteelBlue1 SeaGreen2 DeepPink1 
gray60 gray70 gray80 gray85 gray90
gray95 snow1 snow2 snow3 snow4 seashell1 seashell2 seashell3 seashell4
AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 AntiqueWhite4 bisque1
bisque2 bisque3 bisque4 PeachPuff1 PeachPuff2 PeachPuff3 PeachPuff4
NavajoWhite1 NavajoWhite2 NavajoWhite3 NavajoWhite4 LemonChiffon1
LemonChiffon2 LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2
cornsilk3 cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2
honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 LavenderBlush3
LavenderBlush4 MistyRose1 MistyRose2 MistyRose3 MistyRose4 azure1
azure2 azure3 azure4 SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4
RoyalBlue1 RoyalBlue2 RoyalBlue3 RoyalBlue4 blue2 blue3 blue4
DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue2
SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 DeepSkyBlue3
DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 SkyBlue4 LightSkyBlue1
LightSkyBlue2 LightSkyBlue3 LightSkyBlue4 SlateGray1 SlateGray2
SlateGray3 SlateGray4 LightSteelBlue1 LightSteelBlue2 LightSteelBlue3
LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 LightBlue4 LightCyan1
LightCyan2 LightCyan3 LightCyan4 PaleTurquoise1 PaleTurquoise2
PaleTurquoise3 PaleTurquoise4 CadetBlue1 CadetBlue2 CadetBlue3
CadetBlue4 turquoise1 turquoise2 turquoise3 turquoise4 cyan2
cyan3 cyan4 DarkSlateGray1 DarkSlateGray2 DarkSlateGray3
DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 aquamarine4
DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 DarkSeaGreen4 SeaGreen1
SeaGreen3 SeaGreen4 PaleGreen1 PaleGreen2 PaleGreen3
PaleGreen4 SpringGreen1 SpringGreen2 SpringGreen3 SpringGreen4
green2 green3 green4 chartreuse1 chartreuse2 chartreuse3 chartreuse4
OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 DarkOliveGreen1
DarkOliveGreen2 DarkOliveGreen3 DarkOliveGreen4 khaki1 khaki2 khaki3
khaki4 LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 LightGoldenrod4
LightYellow1 LightYellow2 LightYellow3 LightYellow4 yellow2
yellow3 yellow4 gold2 gold3 gold4 goldenrod1 goldenrod2
goldenrod3 goldenrod4 DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3
DarkGoldenrod4 RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4
IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 sienna4
burlywood1 burlywood2 burlywood3 burlywood4 wheat1 wheat2 wheat3
wheat4 tan1 tan2 tan3 tan4 chocolate1 chocolate2 chocolate3 chocolate4
firebrick1 firebrick2 firebrick3 firebrick4 brown1 brown2 brown3
brown4 salmon1 salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2
LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 DarkOrange1
DarkOrange2 DarkOrange3 DarkOrange4 coral1 coral2 coral3 coral4
tomato1 tomato2 tomato3 tomato4 OrangeRed1 OrangeRed2 OrangeRed3
OrangeRed4 red2 red3 red4 DeepPink2 DeepPink3 DeepPink4
HotPink1 HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 LightPink1
LightPink2 LightPink3 LightPink4 PaleVioletRed1 PaleVioletRed2
PaleVioletRed3 PaleVioletRed4 maroon1 maroon2 maroon3 maroon4
VioletRed1 VioletRed2 VioletRed3 VioletRed4 magenta2 magenta3
magenta4 orchid1 orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4
MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 DarkOrchid1
DarkOrchid2 DarkOrchid3 DarkOrchid4 purple2 purple3 purple4
MediumPurple1 MediumPurple2 MediumPurple3 MediumPurple4 thistle1
thistle2 thistle3 thistle4);

######################################################################
### Hauptprogramm
######################################################################

##########################
### Optionen und Parameter
##########################

&Hilfe if ($#ARGV<0);

while ( $ARGV[0] =~ /^-/ )
{
 OPTION:  
  {
    if ($ARGV[0] eq '-geometry') { shift; $geometry = shift; last OPTION }

    # Sonst:
    die "Option $ARGV[0] gibt es nicht!\n";
  }
}

##########################
### Fenster
##########################

my $main = new MainWindow;

$main->title("$appname $version");
$main->iconname('XDirU');

# Statuszeile
$feedback = $main->Frame();
# $feedback->pack(-side => 'bottom', -fill => 'x');
# $status = $feedback->Text(
# 			  -relief      => 'sunken',
# 			  -height      => 1,
# 			  -background  => 'gray',
# 			  -borderwidth => 2,
# 			 );
$feedback->pack(-side => 'bottom', -fill => 'x');
$statustext = '';
$status = $feedback->Label(-textvariable => \$statustext,
			   -relief       => 'sunken',
			   -height       => 1,
			   -background   => 'gray',
			   -borderwidth  => 2,
			  );

$status->pack(-side => 'left', -fill => 'x', -expand => 1);

$frame = $main->Frame;
$frame->Button(-text    => 'Ende',
              -command => sub{exit},
	     )->pack(-side => 'right');
$frame->Button(-text    => 'ein Verzeichnis zurück',
              -command => sub
	       {
		 Message("Starte neuen XDirUsage in: $anfangsdir/.. ...");
		 system("$0 -geometry $geometry $anfangsdir/.. &");
	       },
	     )->pack(-side => 'left');
$frame->pack(-side => 'top', -fill => 'x');
$main->geometry($geometry);
$main->bind('<q>' => [$main => 'destroy']);

##########################
### Verzeichnisse
##########################

Message('Einlesen der Verzeichnisse...');

# Verzeichnisse feststellen
$anfangsdir = shift;
@dirs = finddirs($anfangsdir);

if ($#dirs<0)
{
  $main->Label(-text => "Keine Unterverzeichnisse!")->pack;
  MainLoop;
}

$summe = 0;
# "du" auf jedes Verzeichnis
foreach $dir (@dirs)
{
  Message("Lese $dir ...");
  $main->update();
  $du = `du -sk '$dir'`;
  next if $du eq '';
  $diruse{$dir} = (split(/\s+/,$du))[0];
  $summe += $diruse{$dir};
}
Message('Details erhalten Sie mit Klick auf ein Kreis-Segment.');

$x0 = 10;
$y0 = 10;
$xcircend = 300;
$ycircend = 300;

my $canvas = $main->Canvas(
			   -relief       => 'sunken',
			   -bd           => 2,
			   -scrollregion => [0, 0, $xcircend, $ycircend*3],
			  );
my $w_vscroll = $main->Scrollbar(-command => [$canvas => 'yview']);
$canvas->configure(-yscrollcommand => [$w_vscroll => 'set']);
$w_vscroll->pack(-side => 'right', -fill => 'y');
$canvas->pack(-expand => 'yes', -fill => 'both');
# Callback für Maus-Klick (Taste 1)
$canvas->bind('all', '<1>' => \&Klick);

$start = 0;
$yrecpos   = 10;
$xabstand  = 10;
$yabstand  = 10;
$recbreite = 10;
$color     = 0;
foreach $dir (sort { $diruse{$b} <=> $diruse{$a} } keys %diruse)
{
  $prozent = $diruse{$dir}*100/$summe;
  $ext = $prozent*3.60;
  $ext = 359.9 if $ext > 359.9;
  $canvas->create('arc', $x0, $y0, $xcircend, $ycircend,
		  -style  => 'pieslice',
		  -fill   => $colors[$color],
		  -start  => $start,
		  -extent => $ext
		 );
  $start += $ext;

  $canvas->create('rectangle',
		  $x0+$xabstand, $ycircend+$yrecpos,
		  $x0+$xabstand+$recbreite, $ycircend+$yrecpos+$recbreite,
		  -fill => $colors[$color],
		  -tags => $dir
		 );
  $canvas->create('text', $x0+$xabstand+$recbreite*2,
		  $ycircend+$yrecpos+$recbreite/2, -anchor => "w",
		  -text => substr($dir,length($anfangsdir)+1)." (".
		  int2dotint($diruse{$dir})." KB, ".int($prozent)."%)");
  $yrecpos = $yrecpos+$yabstand+$recbreite;
  $color++;
}

MainLoop;

######################################################################
### Unterprogramme
######################################################################

sub finddirs
{
  # Parameter: Anfangsverzeichnis
  # Return:    alle Unterverzeichnisse des Anfangsverzeichnisses
  #
  my $dir = shift;
  my @dirs = ();
  foreach $file ( BetterGlob("$dir/*") )
  {
    push @dirs, $file if -d $file;
  }
  return @dirs;
}


sub Kopf
{
  return
  "
$appname $version   -   von Stephan Löscher
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
";
}


sub Hilfe
{
  printumlaute
  Kopf().
"Syntax: xdiru verzeichnisname
Es wird der Platzverbrauch der Unterverzeichnisse aufgelistet.

";
exit;
}


sub Klick
{
  my ($c) = @ARG;
  my $id = $c->find('withtag', 'current');
  $id++ if ($c->gettags('current'))[0] ne 'tags';
  my $newdir = ($c->itemconfigure($id, -tags))[4];
  # Bei neueren Perl/Tk ist der Return-Wert ein Array
  if (ref($newdir) =~ /^ARRAY/)
  {
    $newdir = @{$newdir}[0];
  }
  Message("Starte neuen XDirUsage in: $newdir ...");
  system("$0 -geometry $geometry $newdir &");
}


sub Message
{
  $statustext = shift;
}


######################################################################
#
# Warranty and legal notice
# ~~~~~~~~~~~~~~~~~~~~~~~~~
#
# Copyright (c) 1997 by Stephan Löscher  -  all rights reserved
# My Address: Stephan Löscher, Dr.Troll-str. 3, 82194 Gröbenzell, Germany
# Email: loescher@gmx.de
# WWW: http://www.loescher-online.de/
#
# This program is freeware.
# It is NOT Public-Domain-Software!
# The author (Stephan Löscher) does NOT give up his copyright, but he 
# reserves his copyright. Usage and copying is free of charge for private
# use, but NOT for commercial use!
# 
# You may and should copy this program free of charge, use it,
# give it to your friends, upload it to a BBS or something similar, under
# the following conditions:
# * Don't charge any money for it. If you upload it to a BBS, make sure that
#    it can be downloaded free (without paying for downloading it, except
#    for usage fees that have to be paid anyway). Small copying fees (up to
#    5 DM or 3 $US) may be charged.
#  * Only distribute the whole original package, with all the files included.
#  * This program may not be part of any commercial product or service without
#    the written permission by the author.
#  * If you want to include this program on a CD-ROM and/or book, please send
#    me a free copy of the CD/book (this is not a must, but I would appreciate
#    it very much).
# 
# Distribution of the program is explicitly desired, provided that the above
# conditions are accepted.
# 
# YOU ARE USING THIS PROGRAM AT YOUR OWN RISK! THE AUTHOR (STEPHAN LÖSCHER)
# IS NOT LIABLE FOR ANY DAMAGE OR DATA-LOSS CAUSED BY THE USE OF THIS PROGRAM
# OR BY THE INABILITY TO USE THIS PROGRAM. IF YOU ARE NOT SURE ABOUT THIS, OR
# IF YOU DON'T ACCEPT THIS, THEN DO NOT USE THIS PROGRAM!
# BECAUSE OF THE VARIOUS HARDWARE AND SOFTWARE ENVIRONMENTS INTO WHICH THIS
# PROGRAM MAY BE PUT, NO WARRANTY OF FITNESS FOR A PARTICULAR PURPOSE IS
# OFFERED.
# GOOD DATA PROCESSING PROCEDURE DICTATES THAT ANY PROGRAM BE THOROUGHLY
# TESTED WITH NON-CRITICAL DATA BEFORE RELYING ON IT.
# 
# No part of the documentation may be reproduced, transmitted, transcribed,
# stored in any retrieval system, or translated into any other language in
# whole or in part, in any form or by any means, whether it be electronic,
# mechanical, magnetic, optical, manual or otherwise, without prior written
# consent of the author, Stephan Löscher.
# 
# You may not make any changes or modifications to this software or this
# manual. You may not decompile, disassemble, or otherwise reverse-engineer
# the software in any way.
# If you got the source, then you are permitted to modify it if you
# contact me and tell me your enhancements.
# You also may include the source as a whole or parts of it into other
# programs, as long as you don't make profit directly out of selling
# the result. If you re-use code of this program then do not remove my name!
# If you include this source-code in your projects, mark it clearly as such
# "... derived from code XXX by Stephan Löscher".
# But don't distribute modified code!
# 
# If you believe your copy of this software has been tampered or altered in
# anyway, shape or form, please contact me immediately! Do not hesitate a
# moment to inform me. Remember, this software should be available to all, in
# the original form, so please do not accept modified or damaged versions of
# my software.
# 
# The author reserves his right for taking legal steps if the copyright or the
# license agreement is violated.
# 
# All product names mentioned in this software are trademarks or registered
# trademarks of their respective owners.
# 
# If you have any questions, ideas, suggestions for improvements or if you find
# bugs (I don't hope so.) then feel free to contact me. (Email is appreciated.)
# 
# I'm not a native english speaker. If you are one and discover some strange
# sounding parts in this documentation or in the program, please, feel free
# to point it out to me and give me suggestions for alteration!
# 
# If the program works for you, and you want to honour my efforts, you are
# invited to donate as much as you want... :)
#
# In any case, if you don't like the restrictions in this license, contact
# me, and we can work something out.
#
######################################################################