File Coverage

blib/lib/Proc/ProcessTable/piddler.pm
Criterion Covered Total %
statement 26 287 9.0
branch 0 122 0.0
condition 0 90 0.0
subroutine 9 15 60.0
pod 6 6 100.0
total 41 520 7.8


line stmt bran cond sub pod time code
1             package Proc::ProcessTable::piddler;
2              
3 1     1   66435 use 5.006;
  1         4  
4 1     1   5 use strict;
  1         2  
  1         19  
5 1     1   19 use warnings;
  1         3  
  1         39  
6 1     1   505 use Proc::ProcessTable;
  1         4881  
  1         46  
7 1     1   774 use Text::ANSITable;
  1         100613  
  1         41  
8 1     1   718 use Term::ANSIColor;
  1         8276  
  1         67  
9 1     1   498 use Proc::ProcessTable::InfoString;
  1         867  
  1         97  
10 1     1   435 use Sys::MemInfo qw(totalmem freemem totalswap);
  1         655  
  1         71  
11 1     1   517 use Net::Connection::ncnetstat;
  1         108564  
  1         4101  
12              
13             =head1 NAME
14              
15             Proc::ProcessTable::piddler - Display all process table, open files, and network connections for a PID.
16              
17             =head1 VERSION
18              
19             Version 0.1.0
20              
21             =cut
22              
23             our $VERSION = '0.1.0';
24              
25              
26             =head1 SYNOPSIS
27              
28             use Proc::ProcessTable::piddler;
29              
30             # skip over the less useful stuff by default for less spammy output
31             my $args={
32             txt=>0,
33             unix=>0,
34             pipe=>0,
35             vregroot=>0,
36             dont_dedup=>0,
37             dont_resolv=>0,
38             };
39              
40             my $piddler = Proc::ProcessTable::piddler->new( $args );
41            
42             print $piddler->run( [ 0, 1432 ] );
43              
44             =head1 METHODS
45              
46             =head2 new
47              
48             Initiates the object.
49              
50             One argument is taken and that is a option hash reference
51             of options.
52              
53             my $args={
54             txt=>0,
55             unix=>0,
56             pipe=>0,
57             vregroot=>0,
58             dont_dedup=>0,
59             dont_resolv=>0,
60             };
61            
62             my $piddler = Proc::ProcessTable::piddler->new( $args );
63              
64             =head3 args hash
65              
66             =head4 dont_dedup
67              
68             Don't dedup the file descriptor list.
69              
70             When deduping a list it checks if a file is open in
71             rw, r, or w, only showing it once for any of thsoe modes.
72             Any file with more than one open FD of that mode will have
73             + appended value in the FD volume.
74              
75             The modes below are all also RW and considered that.
76              
77             u
78             ur
79             uw
80              
81             Defaults to 0, false.
82              
83             =head4 dont_resolv
84              
85             Don't resolve PTR addresses.
86              
87             Defaults to 0, false.
88              
89             =head4 pipe
90              
91             Print pipes.
92              
93             Defaults to 0, false.
94              
95             =head4 txt
96              
97             Print the linked libraries used by the binary.
98              
99             Defaults to 0, false.
100              
101             =head4 unix
102              
103             Print unix sockets.
104              
105             Defaults to 0, false.
106              
107             =head4 vregroot
108              
109             Show VREG entries for /.
110              
111             Defaults to 0, false.
112              
113             =cut
114              
115             sub new{
116 0     0 1   my %args;
117 0 0         if (defined($_[1])) {
118 0           %args= %{$_[1]};
  0            
119             }
120              
121 0           my $self = {
122             colors=>[
123             'BRIGHT_YELLOW',
124             'BRIGHT_CYAN',
125             'BRIGHT_MAGENTA',
126             'BRIGHT_BLUE'
127             ],
128             nextColor=>0,
129             timeColors=>[
130             'GREEN',
131             'BRIGHT_GREEN',
132             'RED',
133             'BRIGHT_RED'
134             ],
135             vszColors=>[
136             'GREEN',
137             'YELLOW',
138             'RED',
139             'BRIGHT_BLUE'
140             ],
141             rssColors=>[
142             'BRIGHT_GREEN',
143             'BRIGHT_YELLOW',
144             'BRIGHT_RED',
145             'BRIGHT_BLUE'
146             ],
147             file_colors=>[
148             'BRIGHT_YELLOW',
149             'BRIGHT_CYAN',
150             'BRIGHT_MAGENTA',
151             'BRIGHT_BLUE',
152             'MAGENTA',
153             'BRIGHT_RED'
154             ],
155             processColor=>'BRIGHT_RED',
156             varColor=>'GREEN',
157             valColor=>'WHITE',
158             pidColor=>'BRIGHT_CYAN',
159             cpuColor=>'BRIGHT_MAGENTA',
160             memColor=>'BRIGHT_BLUE',
161             zero_time=>1,
162             zero_flt=>1,
163             files=>1,
164             idColors=>[
165             'WHITE',
166             'BRIGHT_BLUE',
167             'MAGENTA',
168             ],
169             is=>Proc::ProcessTable::InfoString->new,
170             colors=>[
171             'BRIGHT_YELLOW',
172             'BRIGHT_CYAN',
173             'BRIGHT_MAGENTA',
174             'BRIGHT_BLUE'
175             ],
176             txt=>0,
177             pipe=>0,
178             unix=>0,
179             vregroot=>0,
180             dont_dedup=>0,
181             dont_resolv=>0,
182             };
183 0           bless $self;
184              
185 0           my @arg_feed=(
186             'txt', 'pipe', 'unix', 'vregroot', 'dont_dedup', 'dont_resolv'
187             );
188              
189 0           foreach my $feed ( @arg_feed ){
190 0           $self->{$feed}=$args{$feed};
191             }
192              
193 0           return $self;
194             }
195              
196             =head2 run
197              
198             This runs it and returns a string.
199              
200             One option is taken and that is a array ref of PIDs
201             to do.
202              
203             print $piddler->run( [ 0, 1432 ] );
204              
205             =cut
206              
207             sub run{
208 0     0 1   my $self=$_[0];
209 0           my @pids;
210 0 0         if (defined($_[1])) {
211 0           @pids= @{$_[1]};
  0            
212             }
213              
214 0 0         if ( ! defined( $pids[0] ) ){
215 0           return '';
216             }
217              
218 0           my %pids_hash;
219 0           foreach my $pid ( @pids ){
220 0           $pids_hash{$pid}=$pid;
221             }
222              
223 0           my $p = Proc::ProcessTable->new;
224 0           my $pt = $p->table;
225              
226             # figure out what all keys the process table is reporting
227 0           my @proc_keys=keys( %{ $pt->[0] } );
  0            
228 0           my %proc_keys_hash;
229 0           foreach my $proc_key ( @proc_keys ){
230 0           $proc_keys_hash{$proc_key}=1;
231             }
232             # remove the ones we actually use
233 0           delete( $proc_keys_hash{pctcpu} );
234 0           delete( $proc_keys_hash{uid} );
235 0           delete( $proc_keys_hash{pid} );
236 0           delete( $proc_keys_hash{gid} );
237 0           delete( $proc_keys_hash{vmsize} );
238 0           delete( $proc_keys_hash{rss} );
239 0           delete( $proc_keys_hash{state} );
240 0           delete( $proc_keys_hash{wchan} );
241 0           delete( $proc_keys_hash{cmndline} );
242 0           delete( $proc_keys_hash{size} );
243 0           delete( $proc_keys_hash{time} );
244 0 0         if( defined( $proc_keys_hash{pctmem} ) ){
245 0           delete( $proc_keys_hash{pctmem} );
246             }
247 0 0         if( defined( $proc_keys_hash{groups} ) ){
248 0           delete( $proc_keys_hash{groups} );
249             }
250 0 0         if ( defined( $proc_keys_hash{cmdline} ) ){
251 0           delete( $proc_keys_hash{cmdline} );
252             }
253 0           @proc_keys=sort(keys( %proc_keys_hash ));
254              
255 0           my @procs;
256 0           foreach my $proc ( @{ $pt } ){
  0            
257 0 0         if ( defined( $pids_hash{ $proc->pid } ) ){
258 0           push( @procs, $proc );
259             }
260             }
261              
262 0 0         if (!defined( $procs[0] )){
263 0           return ''
264             }
265              
266 0           my $toReturn='';
267 0           my $first=1;
268 0           foreach my $proc ( @procs ){
269 0           my $tb = Text::ANSITable->new;
270 0           $tb->border_style('Default::none_ascii');
271 0           $tb->color_theme('Default::no_color');
272 0           $tb->show_header(0);
273 0           $tb->set_column_style(0, pad => 0);
274 0           $tb->set_column_style(1, pad => 1);
275 0           $tb->columns( ['var','val'] );
276              
277             #
278             # PID
279             #
280 0           my @data;
281             push( @data, [
282             color( $self->{varColor} ).'PID'.color('reset'),
283 0           color( $self->{pidColor} ).$proc->pid.color('reset')
284             ]);
285              
286             #
287             # UID
288             #
289 0           my $user=getpwuid($proc->{uid});
290 0 0         if ( ! defined( $user ) ) {
291 0           $user=color( $self->{idColors}[0] ).$proc->{uid}.color('reset');
292             }else{
293             $user=color( $self->{idColors}[0] ).$user.
294             color( $self->{idColors}[1] ).'('.
295             color( $self->{idColors}[2] ).$proc->{uid}.
296 0           color( $self->{idColors}[1] ).')'
297             .color('reset');
298             }
299              
300             push( @data, [
301 0           color( $self->{varColor} ).'UID'.color('reset'),
302             $user.' '.color('reset')
303             ]);
304              
305             #
306             # GID
307             #
308 0           my $group=getgrgid($proc->{gid});
309 0 0         if ( ! defined( $group ) ) {
310 0           $group=color( $self->{idColors}[0] ).$proc->{gid}.color('reset');
311             }else{
312             $group=color( $self->{idColors}[0] ).$group.
313             color( $self->{idColors}[1] ).'('.
314             color( $self->{idColors}[2] ).$proc->{gid}.
315 0           color( $self->{idColors}[1] ).')'
316             .color('reset');
317             }
318              
319             push( @data, [
320 0           color( $self->{varColor} ).'GID'.color('reset'),
321             $group.' '.color('reset')
322             ]);
323              
324             #
325             # Groups
326             #
327 0 0         if ( defined( $proc->{groups} ) ){
328 0           my @groups;
329 0           foreach my $current_group ( @{ $proc->{groups} } ){
  0            
330 0           $group=getgrgid( $current_group );
331 0 0         if ( ! defined( $group ) ) {
332 0           $group=color( $self->{idColors}[0] ).$current_group.color('reset');
333             }else{
334             $group=color( $self->{idColors}[0] ).$group.
335             color( $self->{idColors}[1] ).'('.
336             color( $self->{idColors}[2] ).$current_group.
337 0           color( $self->{idColors}[1] ).')'
338             .color('reset');
339             }
340 0           push( @groups, $group );
341             }
342              
343             push( @data, [
344 0           color( $self->{varColor} ).'Groups'.color('reset'),
345             join( ' ', @groups )
346             ]);
347             }
348              
349             #
350             # PCT CPU
351             #
352             push( @data, [
353             color( $self->{varColor} ).'CPU%'.color('reset'),
354 0           color( $self->{valColor} ).$proc->pctcpu.color('reset')
355             ]);
356              
357             #
358             # PCT mem
359             #
360 0           my $mem;
361 0 0         if ( !defined( $proc->{pctmem} ) ) {
362 0           $mem=($proc->{rss} / totalmem)*100;
363 0           $mem=sprintf('%.2f', $mem);
364             } else {
365 0           $mem=sprintf('%.2f', $proc->{pctmem});
366             }
367             push( @data, [
368             color( $self->{varColor} ).'MEM%'.color('reset'),
369 0           color( $self->{valColor} ).$mem.color('reset')
370             ]);
371              
372             #
373             # VSZ
374             #
375             push( @data, [
376 0           color( $self->{varColor} ).'VSZ'.color('reset'),
377             $self->memString( $proc->size, 'vsz' )
378             ]);
379              
380             #
381             # RSS
382             #
383             push( @data, [
384 0           color( $self->{varColor} ).'RSS'.color('reset'),
385             $self->memString( $proc->rss, 'rss' )
386             ]);
387              
388             #
389             # time
390             #
391             push( @data, [
392 0           color( $self->{varColor} ).'Time'.color('reset'),
393             $self->timeString( $proc->time )
394             ]);
395              
396             #
397             # info
398             #
399             push( @data, [
400             color( $self->{varColor} ).'Info'.color('reset'),
401 0           color( $self->{valColor} ).$self->{is}->info( $proc ).color('reset')
402             ]);
403              
404             #
405             # misc ones...
406             #
407 0           foreach my $key ( @proc_keys ){
408 0 0         if ( $proc->{$key} !~ /^$/ ){
409 0           my $print_it=1;
410 0           my $value;
411              
412 0 0 0       if (
    0 0        
413             ( $key =~ /time$/ ) &&
414             ( $proc->{$key} =~ /\.0*$/ ) &&
415             ( $self->{zero_time} )
416             ){
417 0           $print_it=0;
418             }elsif( $key =~ /time$/ ){
419 0           $value=$self->timeString( $proc->{$key} );
420             }
421              
422 0 0 0       if (
      0        
423             ( $key =~ /flt$/ ) &&
424             ( $proc->{$key} eq 0 ) &&
425             ( $self->{zero_flt} )
426             ){
427 0           $print_it=0;
428             }
429              
430 0 0         if ( $key =~ /^start$/ ){
431 0           $value=$self->startString( $proc->{start} );
432             }
433              
434 0 0         if ( !defined( $value ) ){
435 0           $value=color( $self->{valColor} ).$proc->{$key}.color('reset');
436             }
437              
438 0 0         if ( $print_it ){
439             push( @data, [
440 0           color( $self->{varColor} ).$key.color('reset'),
441             $value,
442             ]);
443             }
444             }
445             }
446              
447             #
448             # cmndline
449             #
450 0 0         if ( $proc->{cmndline} !~ /^$/ ){
451             push( @data, [
452             color( $self->{varColor} ).'Cmndline'.color('reset'),
453 0           color( $self->{processColor} ).$proc->{cmndline}.color('reset')
454             ]);
455             }
456              
457             #
458             # gets the open files
459             #
460 0           my $open_files='';
461 0           my $pid=$proc->pid;
462 0           my $output_raw=`lsof -n -l -P -p $pid`;
463 0 0 0       if (
      0        
464             ( $? eq 0 ) ||
465             (
466             ( $^O =~ /linux/ ) &&
467             ( $? eq 256 )
468             )
469             ){
470              
471 0           my $ftb = Text::ANSITable->new;
472 0           $ftb->border_style('Default::none_ascii');
473 0           $ftb->color_theme('Default::no_color');
474 0           $ftb->show_header(1);
475 0           $ftb->set_column_style(0, pad => 0);
476 0           $ftb->set_column_style(1, pad => 1);
477 0           $ftb->set_column_style(2, pad => 0);
478 0           $ftb->set_column_style(3, pad => 1);
479 0           $ftb->set_column_style(4, pad => 0);
480             $ftb->columns([
481             color( $self->{varColor} ).'FD'.color('reset'),
482             color( $self->{varColor} ).'TYPE'.color('reset'),
483             color( $self->{varColor} ).'DEVICE'.color('reset'),
484             color( $self->{varColor} ).'SIZE/OFF'.color('reset'),
485             color( $self->{varColor} ).'NODE'.color('reset'),
486 0           color( $self->{varColor} ).'NAME'.color('reset')
487             ]);
488              
489 0           my @fdata;
490              
491             #
492             my %rw_filehandles;
493 0           my %r_filehandles;
494 0           my %w_filehandles;
495 0           my @lines=split(/\n/, $output_raw);
496 0           my $line_int=1;
497 0           while ( defined( $lines[$line_int] ) ){
498 0           my $line=substr $lines[$line_int], 10;
499 0           my @line_split=split(/[\ \t]+/, $line );
500              
501 0 0         if ( !defined( $line_split[7] )){
502 0           $line_split[7]='';
503             }
504              
505             # checks if it is a line we don't want
506 0           my $dont_add=0;
507 0 0 0       if (
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
508             # IP stuff... handled by ncnetstat
509             ( $line_split[3] =~ /^IPv/ ) ||
510             # library... spammy... only print if asked
511             (
512             ( $line_split[2] =~ /^txt$/ ) &&
513             ( ! $self->{txt} )
514             ) ||
515             # pipe... spammy... only print if asked
516             (
517             ( $line_split[3] =~ /^[Pp][Ii][Pp][Ee]$/ ) &&
518             ( ! $self->{pipe} )
519             ) ||
520             # unix... spammy... only print if asked
521             (
522             ( $line_split[3] =~ /^[Uu][Nn][Ii][Xx]$/ ) &&
523             ( ! $self->{unix} )
524             ) ||
525             # vreg /....can by spammy with somethings like firefox
526             (
527             ( $line_split[3] =~ /^[Vv][Rr][Ee][Gg]$/ ) &&
528             ( $line_split[7] =~ /^\/$/ ) &&
529             ( ! $self->{vregroot} )
530             )
531             ){
532 0           $dont_add=1;
533             }
534              
535             # begin deduping
536 0           my $name= color( $self->{file_colors}[5] ).$line_split[7].color( 'reset' );
537 0 0         if ( ! $self->{dont_dedup} ){
538 0 0 0       if (
      0        
539             ( $line_split[3] =~ /[Vv][Rr][Ee][Gg]/ ) ||
540             ( $line_split[3] =~ /[Vv][Dd][Ii][Dd]/ ) ||
541             ( $line_split[3] =~ /[Vv][Cc][Hh][Rr]/ )
542             ) {
543 0 0 0       if (
    0 0        
    0 0        
      0        
544             ( $line_split[2] =~ /u/ ) ||
545             ( $line_split[2] =~ /rw/ ) ||
546             ( $line_split[2] =~ /wr/ )
547             ) {
548 0 0         if (! defined( $rw_filehandles{ $name } ) ) {
549 0           $rw_filehandles{ $name } = 1;
550             } else {
551 0           $rw_filehandles{ $name }++;
552             }
553             } elsif (
554             ( $line_split[2] !~ /u/ ) ||
555             ( $line_split[2] =~ /r/ )
556             ) {
557 0 0         if (! defined( $r_filehandles{ $name } ) ) {
558 0           $r_filehandles{ $name } = 1;
559             } else {
560 0           $r_filehandles{ $name }++;
561             }
562             } elsif (
563             ( $line_split[2] !~ /u/ ) ||
564             ( $line_split[2] =~ /w/ )
565             ) {
566 0 0         if (! defined( $w_filehandles{ $name } ) ) {
567 0           $w_filehandles{ $name } = 1;
568             } else {
569 0           $w_filehandles{ $name }++;
570             }
571             }
572             }
573             }
574              
575 0 0         if ( ! $dont_add ) {
576             push( @fdata, [
577             color( $self->{file_colors}[0] ).$line_split[2].color( 'reset' ),
578             color( $self->{file_colors}[1] ).$line_split[3].color( 'reset' ),
579             color( $self->{file_colors}[2] ).$line_split[4].color( 'reset' ),
580             color( $self->{file_colors}[3] ).$line_split[5].color( 'reset' ),
581 0           color( $self->{file_colors}[4] ).$line_split[6].color( 'reset' ),
582             $name,
583             ]);
584             }
585              
586 0           $line_int++;
587             }
588              
589             # finalize deduping
590 0           my @final_fdata;
591 0 0         if ( ! $self->{dont_dedup} ){
592 0           my %rw_dedup;
593             my %r_dedup;
594 0           my %w_dedup;
595 0           foreach my $line ( @fdata ){
596 0 0 0       if (
      0        
597             ( $line->[1] =~ /[Vv][Rr][Ee][Gg]/ ) ||
598             ( $line->[1] =~ /[Vv][Dd][Ii][Dd]/ ) ||
599             ( $line->[1] =~ /[Vv][Cc][Hh][Rr]/ )
600             ){
601 0           my $add_line=1;
602 0 0 0       if (
    0 0        
    0 0        
      0        
603             ( $line->[0] =~ /u/ ) ||
604             ( $line->[0] =~ /rw/ ) ||
605             ( $line->[0] =~ /wr/ )
606             ) {
607 0 0         if( defined( $rw_dedup{ $line->[5] } ) ){
608 0           $add_line=0;
609             }else{
610 0 0         if ($rw_filehandles{ $line->[5] } > 1){
611 0           $line->[0]=$line->[0].'+';
612             }
613 0           $rw_dedup{ $line->[5] } = 1;
614             }
615             } elsif (
616             ( $line->[0] !~ /u/ ) ||
617             ( $line->[0] =~ /r/ )
618             ) {
619 0 0         if( defined( $r_dedup{ $line->[5] } ) ){
620 0           $add_line=0;
621             }else{
622 0 0         if ($r_filehandles{ $line->[5] } > 1){
623 0           $line->[0]=$line->[0].'+';
624             }
625 0           $r_dedup{ $line->[5] } = 1;
626             }
627             } elsif (
628             ( $line->[0] !~ /u/ ) ||
629             ( $line->[0] =~ /w/ )
630             ) {
631 0 0         if( defined( $w_dedup{ $line->[5] } ) ){
632 0           $add_line=0;
633             }else{
634 0 0         if ($w_filehandles{ $line->[5] } > 1){
635 0           $line->[0]=$line->[0].'+';
636             }
637 0           $w_dedup{ $line->[5] } = 1;
638             }
639             }
640              
641 0 0         if ( $add_line ){
642 0           push( @final_fdata, [
643             $line->[0],
644             $line->[1],
645             $line->[2],
646             $line->[3],
647             $line->[4],
648             $line->[5],
649             ]);
650             }
651             }else{
652 0           push( @final_fdata, \@{ $line } );
  0            
653             }
654             }
655 0           $ftb->add_rows( \@final_fdata );
656             }else{
657 0           $ftb->add_rows( \@fdata );
658             }
659              
660              
661 0           $open_files=$ftb->draw;
662             }
663              
664             #
665             # handle the netconnection
666             #
667 0           my $netstat='';
668 0           my @filters=(
669             {
670             type=>'PID',
671             invert=>0,
672             args=>{
673             pids=>[$proc->pid],
674             }
675             }
676             );
677 0           my $ptr=1;
678 0 0         if ( $self->{dont_resolv} ){
679 0           $ptr=0;
680             }
681 0           my $ncnetstat=Net::Connection::ncnetstat->new(
682             {
683             ptr=>$ptr,
684             command=>0,
685             command_long=>0,
686             wchan=>0,
687             pct_show=>0,
688             no_pid_user=>1,
689             match=>{
690             checks=>\@filters,
691             }
692             }
693             );
694 0           $netstat=$ncnetstat->run;
695              
696              
697             #
698             # adds the new item
699             #
700 0           $tb->add_rows( \@data );
701 0 0         if ( $first ){
702 0           $first=0;
703 0           $toReturn=$toReturn.$tb->draw.$open_files.$netstat;
704             }else{
705 0           $toReturn=$toReturn.$open_files."\n\n".$tb->draw;
706             }
707             }
708              
709 0           return $toReturn;
710             }
711              
712             =head2 timeString
713              
714             Turns the raw run string into something usable.
715              
716             =cut
717              
718             sub timeString{
719 0     0 1   my $self=$_[0];
720 0           my $time=$_[1];
721              
722 0 0         if ( $^O =~ /^linux$/ ) {
723 0           $time=$time/1000000;
724             }
725              
726 0           my $hours=0;
727 0 0         if ( $time >= 3600 ) {
728 0           $hours = $time / 3600;
729             }
730 0           my $loSeconds = $time % 3600;
731 0           my $minutes=0;
732 0 0         if ( $time >= 60 ) {
733 0           $minutes = $loSeconds / 60;
734             }
735 0           my $seconds = $loSeconds % 60;
736              
737             #nicely format it
738 0           $hours=~s/\..*//;
739 0           $minutes=~s/\..*//;
740             #$seconds=sprintf('%.f',$seconds);
741              
742             #this will be returned
743 0           my $toReturn='';
744              
745             #process the hours bit
746 0 0         if ( $hours == 0 ) {
    0          
747             #don't do anything if time is 0
748             } elsif (
749             $hours >= 10
750             ) {
751 0           $toReturn=color($self->{timeColors}->[3]).$hours.':';
752             } else {
753 0           $toReturn=color($self->{timeColors}->[2]).$hours.':';
754             }
755              
756             #process the minutes bit
757 0 0 0       if (
758             ( $hours > 0 ) ||
759             ( $minutes > 0 )
760             ) {
761 0           $toReturn=$toReturn.color( $self->{timeColors}->[1] ). $minutes.':';
762             }
763              
764 0           $toReturn=$toReturn.color( $self->{timeColors}->[0] ).$seconds.color('reset');
765              
766 0           return $toReturn;
767             }
768              
769             =head2 memString
770              
771             Turns the raw run string into something usable.
772              
773             =cut
774              
775             sub memString{
776 0     0 1   my $self=$_[0];
777 0           my $mem=$_[1];
778 0           my $type=$_[2];
779              
780 0           my $toReturn='';
781              
782 0 0 0       if ( $mem < '10000' ) {
    0 0        
    0          
    0          
783 0           $toReturn=color( $self->{$type.'Colors'}[0] ).$mem;
784             } elsif (
785             ( $mem >= '10000' ) &&
786             ( $mem < '1000000' )
787             ) {
788 0           $mem=$mem/1000;
789              
790             $toReturn=color( $self->{$type.'Colors'}[0] ).$mem.
791 0           color( $self->{$type.'Colors'}[3] ).'k';
792             } elsif (
793             ( $mem >= '1000000' ) &&
794             ( $mem < '1000000000' )
795             ) {
796 0           $mem=($mem/1000)/1000;
797 0           $mem=sprintf('%.3f', $mem);
798 0           my @mem_split=split(/\./, $mem);
799              
800             $toReturn=color( $self->{$type.'Colors'}[1] ).$mem_split[0].'.'.color( $self->{$type.'Colors'}[0] ).$mem_split[1].
801 0           color( $self->{$type.'Colors'}[3] ).'M';
802             } elsif ( $mem >= '1000000000' ) {
803 0           $mem=(($mem/1000)/1000)/1000;
804 0           $mem=sprintf('%.3f', $mem);
805 0           my @mem_split=split(/\./, $mem);
806              
807             $toReturn=color( $self->{$type.'Colors'}[2] ).$mem_split[0].'.'.color( $self->{$type.'Colors'}[1] ).$mem_split[1].
808 0           color( $self->{$type.'Colors'}[3] ).'G';
809             }
810              
811 0           return $toReturn.color('reset');
812             }
813              
814             =head2 startString
815              
816             Generates a short time string based on the supplied unix time.
817              
818             =cut
819              
820             sub startString{
821 0     0 1   my $self=$_[0];
822 0           my $startTime=$_[1];
823              
824 0           my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($startTime);
825 0           my ($csec,$cmin,$chour,$cmday,$cmon,$cyear,$cwday,$cyday,$cisdst) = localtime(time);
826              
827             #add the required stuff to make this sane
828 0           $year += 1900;
829 0           $cyear += 1900;
830 0           $mon += 1;
831 0           $cmon += 1;
832              
833             #find the most common one and return it
834 0 0         if ( $year ne $cyear ) {
835 0           return $year.sprintf('%02d', $mon).sprintf('%02d', $mday).'-'.sprintf('%02d', $hour).':'.sprintf('%02d', $min);
836             }
837 0 0         if ( $mon ne $cmon ) {
838 0           return sprintf('%02d', $mon).sprintf('%02d', $mday).'-'.sprintf('%02d', $hour).':'.sprintf('%02d', $min);
839             }
840 0 0         if ( $mday ne $cmday ) {
841 0           return sprintf('%02d', $mday).'-'.sprintf('%02d', $hour).':'.sprintf('%02d', $min);
842             }
843              
844             #just return this for anything less
845 0           return sprintf('%02d', $hour).':'.sprintf('%02d', $min);
846             }
847              
848             =head2 nextColor
849              
850             Returns the next color.
851              
852             =cut
853              
854             sub nextColor{
855 0     0 1   my $self=$_[0];
856              
857 0           my $color;
858              
859 0 0         if ( defined( $self->{colors}[ $self->{nextColor} ] ) ) {
860 0           $color=$self->{colors}[ $self->{nextColor} ];
861 0           $self->{nextColor}++;
862             } else {
863 0           $self->{nextColor}=0;
864 0           $color=$self->{colors}[ $self->{nextColor} ];
865 0           $self->{nextColor}++;
866             }
867              
868 0           return $color;
869             }
870              
871             =head1 AUTHOR
872              
873             Zane C. Bowers-Hadley, C<< >>
874              
875             =head1 BUGS
876              
877             Please report any bugs or feature requests to C, or through
878             the web interface at L. I will be notified, and then you'll
879             automatically be notified of progress on your bug as I make changes.
880              
881              
882              
883              
884             =head1 SUPPORT
885              
886             You can find documentation for this module with the perldoc command.
887              
888             perldoc Proc::ProcessTable::piddler
889              
890              
891             You can also look for information at:
892              
893             =over 4
894              
895             =item * RT: CPAN's request tracker (report bugs here)
896              
897             L
898              
899             =item * AnnoCPAN: Annotated CPAN documentation
900              
901             L
902              
903             =item * CPAN Ratings
904              
905             L
906              
907             =item * Search CPAN
908              
909             L
910              
911             =item * Repository
912              
913             L
914              
915             =back
916              
917              
918             =head1 ACKNOWLEDGEMENTS
919              
920              
921             =head1 LICENSE AND COPYRIGHT
922              
923             This software is Copyright (c) 2019 by Zane C. Bowers-Hadley.
924              
925             This is free software, licensed under:
926              
927             The Artistic License 2.0 (GPL Compatible)
928              
929              
930             =cut
931              
932             1; # End of Proc::ProcessTable::piddler