use strict; use warnings; use English; use Data::Dumper; use Tk; use Sort::Fields; # Globals... my %W; # Hash for widgets my $ACTIVESORT; # Currently active sort button # Set default command... my $CMD = 'ls -l'; if($OSNAME eq 'MSWin32') { $CMD = 'dir /-c /a-d' }; # Create the window... _createWin(); # Start the user off by doing the default command... _doCmd($CMD); # Go to event processing mode... MainLoop(); #################################################################### # Subroutine: _findFieldStarts (internal) # This routine requires all lines of input text to have the same # number of fields. It finds the leftmost initial character # position of each field, and indicates if the field is numeric # or not. # Arguments # $_[0] - Number of fields in all lines of text (mandatory) # $_[1] - Pointer to text list (mandatory) # Returns # List1: index - field number # contents - position of leftmost character # List2: index - field number # contents - field type ('n' if numeric) #################################################################### sub _findFieldStarts { my $fields = shift || die "Missing fields per line"; my $txtp = shift || die "Missing Text Pointer"; # Initialize @starts to be max display width (in chars)... my @starts = (100) x $fields; # Initialize @types to be all numeric... my @types = ('n') x $fields; foreach my $line (@{$txtp}) { # Split on ' ' (not \s+) for initial spaces in field 1 # see http://www.perlmonks.org/?node_id=850448 my @words = split(' ', $line); my $start=0; # map returns list of starting positions for given line... my %h = map { my $i = index($line, $_, $start); # start pos my $l = length($_); # length $start = $i + $l; # next start my $number = 'n'; if($_=~/\s*\D+\s*/){$number=''}; $i, $number; } @words; # Sort hash keys to get starting positions in order... my @s = sort {$a<=>$b} keys(%h); # See if current line will change @starts or @types... foreach my $i (0..$fields-1) { # Keep leftmost (lowest numbered) positions... if( $starts[$i] > $s[$i] ) { $starts[$i] = $s[$i]; } # Any non-numerical chars negates numerical sort... if($h{$s[$i]} ne 'n') { $types[$i] = $h{$s[$i]}; } } # Force first field to start at char=0 (if there is initial # whitespace, it won't want to start there)... $starts[0] = 0; } return(\@starts, \@types); } #################################################################### # Subroutine: _groupByFields (internal) # This routine groups the given text by fields/line. This is # so we can pick one set of fields to autosort on. # Arguments # $_[0] - Pointer to list of text (mandatory) # Returns # Hash pointer: index - fields/line # contents - All lines with $index fields #################################################################### sub _groupByFields { my $txtp = shift || die "Missing Text Pointer"; my %grouped; # Txt grouped by number of fields/line foreach my $line ( @{$txtp} ) { no warnings; # http://www.perlmonks.org/?node_id=313616 # Split on ' ' (not /s+) for initial spaces in field 1: # http://www.perlmonks.org/?node_id=850448 my $f = scalar(split(' ', $line)) || next; use warnings; # Group line with others having same number of fields... push(@{$grouped{$f}}, $line); } return(\%grouped); } #################################################################### # Subroutine: _doCmd (internal) # This routine executes the provided command, figures out what # subset of text to use, and supplies it to the GUI routines. # Arguments # $_[0] - Text of command to run (Mandatory) # Returns # None #################################################################### sub _doCmd { my $cmd = shift || die "Missing command"; # Run command to get data... my @out = split(/\n/, `$cmd`); chomp(@out); if(!scalar(@out)) { die "Bad command response: $cmd\n", Dumper(\@out), "\n"; } # Remove "bad" things (hoo-boy this is a hack)... if($OSNAME eq 'MSWin32') { # WINDOWS: Remove all non-file entry lines... @out = grep !/^ /, @out; }else{ # UNIX: Remove initial "total" line... if( $out[0] =~/^total \d+$/ ) { shift(@out) }; } # Group text by the number of fields-per-line... my $fGroups_p = _groupByFields(\@out); # Find the most popular fieldsize in this data... my ($maxLines, $maxFields) = (0, 0); foreach my $g (keys(%{$fGroups_p})) { my $lines = scalar(@{$fGroups_p->{$g}}); if($maxLines < $lines) { ($maxFields, $maxLines) = ($g, $lines); } } print STDERR "Autosplitting lines with $maxFields fields only.\n"; # Find the starting character positions and type for each field... my ($fstart_p, $ftype_p) = _findFieldStarts($maxFields,$fGroups_p->{$maxFields}); # Put data into GUI... _guiData($fGroups_p->{$maxFields}, $fstart_p, $ftype_p); return(); } #################################################################### # Subroutine: _createWin (internal) # This routine sets up the GUI # Arguments # None # Returns # Pointer to MainWindow #################################################################### sub _createWin { # Check if window already exists... if(defined($W{Top})) { # Might want to raise the window to the top here... warn "\aERROR - Window Already Exists\n"; return; } # Create new text window... my $top = MainWindow->new(); $W{Top} = $top; $top->title("Autosort of ls(1) Output"); $top->minsize(600,300); $top->protocol('WM_DELETE_WINDOW', sub{exit}); # Setup to destroy global widgets upon destruction... $top->OnDestroy(sub{undef $top;}); # Define an up arrow... my $arrowUpBits = pack("b8" x 5, "........", "...11...", "..1111..", ".111111.", "........"); # Define a down arrow... my $arrowDnBits = pack("b8" x 5, "........", ".111111.", "..1111..", "...11...", "........"); # Define an idle arrow... my $arrowIdleBits = pack("b8" x 5, "........", "...11...", "..1111..", "...11...", "........"); # Create the bitmaps... $top->DefineBitmap('arrowUp' => 8, 5, $arrowUpBits); $top->DefineBitmap('arrowDn' => 8, 5, $arrowDnBits); $top->DefineBitmap('arrowIdle' => 8, 5, $arrowIdleBits); # Put a button frame in first, to hold the sort buttons on top... $W{BFrame} = $top->Frame()->pack(-anchor=>'w', -fill=>'x'); # Put in a do-nothing button, just for initial setup & sizing... push( @{$W{SortButtons}}, $W{BFrame}->Button(-bitmap=>'arrowIdle', -state=>'disabled')->pack(-side=>'left') ); # Put in the files text box second... $W{File} = $top->Scrolled('Text', -height=>4, -state=>'disabled', -scrollbars=>'osoe')-> pack(-expand=>1, -fill=>'both'); # Put in a frame below the text box... $W{CmdF} = $top->Frame()->pack(-fill=>'x'); # Add label, entry, & button... $W{CmdF}->Label(-text=>'Command:')->pack(-side=>'left'); $W{CmdEnt} = $W{CmdF}->Entry(-relief=>'sunken', -textvariable=>\$CMD)-> pack(-side=>'left', -expand=>1, -fill=>'x'); $W{CmdBut} = $W{CmdF}->Button(-text=>'run', -command=>sub{ _doCmd($CMD); })->pack(-side=>'left'); return($top); } #################################################################### # Subroutine: _guiData (internal) # This routine puts the text into the GUI & adds autosort buttons # Arguments # $_[0] - Pointer to text list (mandatory) # $_[1] - Pointer to list of field starting positions # $_[2] - Pointer to list of field types # Returns # None #################################################################### sub _guiData { my $txt_p = shift || die "Missing Text Pointer"; my $fstart_p = shift || die "Missing field starts"; my $ftype_p = shift || die "Missing field types"; # Put the text up into the GUI $W{File}->configure(-state=>'normal'); $W{File}->Contents( join("\n", @$txt_p) ); $W{File}->configure(-state=>'disabled'); $W{File}->update; # for bbox below # map transforms character start positions into pixels... my @starts = map { # The first element bbox returned list is start pos... ($W{File}->bbox("1.$_"))[0]; # pixel conversion } @{$fstart_p}; # Remove any existing buttons... my $b; while ( $b = pop(@{$W{SortButtons}}) ) { $b->destroy; undef($ACTIVESORT); } # Put up the new buttons... foreach my $b (0..(scalar(@$fstart_p)-1)) { # ending pixel (next start - fudge, or end of line)... my $w; if($starts[$b+1]) { $w = ($starts[$b+1] - 8) - $starts[$b]; } _addButton($txt_p, \$b, $ftype_p->[$b], $w,); } } #################################################################### # Subroutine: _addButton (internal) # This routine puts a sort button in the GUI. Note, use pointer # for $_[1] so zero value won't fire "die". # Arguments # $_[0] - Pointer to text list (mandatory) # $_[1] - Pointer to field number to sort on (mandatory) # $_[2] - Field type (optional) # $_[3] - Width of button (optional) # Returns # None #################################################################### sub _addButton { my $txt_p = shift || die "Missing text pointer"; my $fp = shift || die "Missing field number pointer"; my $ft = shift; my $width = shift; # Create $f for fieldsort below (bump up list index, add type)... my $f = ($$fp + 1) . $ft; # Put a button in the button frame... $W{SortButtons}[$$fp] = $W{BFrame}->Button( -command=>sub{ # Turn of any highlighted sort button... if ( (defined($ACTIVESORT)) && ($$fp != $ACTIVESORT) ) { $W{SortButtons}[$ACTIVESORT]->configure( -bitmap=>'arrowIdle'); } # Make this button the active one... $ACTIVESORT = $$fp; # Setup toggling of the button (up->down, down->up)... my $next; my $current = $W{SortButtons}[$$fp]->cget('-bitmap'); if($current eq 'arrowUp') { $next = 'arrowDn' } elsif($current eq 'arrowDn') { $next = 'arrowUp' } elsif($current eq 'arrowIdle') { $next = 'arrowDn' } else { die "Invalid Arrow Value: current=$current\n" }; # Toggle the button... $W{SortButtons}[$$fp]->configure(-bitmap=>$next); # Get fieldsort to work with initial spaces in field 1: # http://www.perlmonks.org/?node_id=850501 my @sorted = fieldsort( "".qr/(?configure(-state=>'normal'); $W{File}->Contents( join("\n", @sorted) ); $W{File}->configure(-state=>'disabled'); }, -bitmap=>'arrowIdle' ); # Expand the last button only... if(defined($width)) { $W{SortButtons}[$$fp]->configure(-width=>$width); $W{SortButtons}[$$fp]->pack(-side=>'left'); }else{ $W{SortButtons}[$$fp]-> pack(-side=>'left', -expand=>1, -fill=>'x'); } }