File Coverage

blib/lib/Proc/ProcessTable/Colorizer.pm
Criterion Covered Total %
statement 21 23 91.3
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 29 31 93.5


line stmt bran cond sub pod time code
1             package Proc::ProcessTable::Colorizer;
2              
3 1     1   47727 use 5.006;
  1         3  
4 1     1   4 use strict;
  1         2  
  1         16  
5 1     1   5 use warnings;
  1         6  
  1         57  
6 1     1   7 use base 'Error::Helper';
  1         2  
  1         299  
7 1     1   801 use Proc::ProcessTable;
  1         3474  
  1         36  
8 1     1   361 use Term::ANSIColor;
  1         6113  
  1         57  
9 1     1   352 use Text::Table;
  1         7014  
  1         28  
10 1     1   97 use Term::Size;
  0            
  0            
11              
12             if ( $^O =~ /bsd/ ){
13             use BSD::Process;
14             }
15              
16             =head1 NAME
17              
18             Proc::ProcessTable::Colorizer - Like ps, but with colored columns and enhnaced functions for searching.
19              
20             =head1 VERSION
21              
22             Version 0.0.0
23              
24             =cut
25              
26             our $VERSION = '0.0.0';
27              
28              
29             =head1 SYNOPSIS
30              
31             use Proc::ProcessTable::Colorizer;
32              
33             my $cps = Proc::ProcessTable::Colorizer->new;
34             print $cps->colorize;
35              
36             This module uses L for error reporting.
37              
38             As of right now this module is not really user friend and will likely be going through lots of changes as it grows.
39              
40             Linux is also not as well supported given the limitations of Proc::ProcessTable and there is nothig similar to
41             L for Linux.
42              
43             =head1 METHODS
44              
45             =head2 new
46              
47             Creates a new object. This method will never error.
48              
49             my $cps=Proc::ProcessTable::Colorizer->new;
50              
51             =cut
52              
53             sub new {
54             my $self={
55             perror=>undef,
56             error=>undef,
57             errorString=>'',
58             errorExtra=>{
59             1=>'badTimeString',
60             2=>'badPctcpuString',
61             },
62             colors=>[
63             'BRIGHT_YELLOW',
64             'BRIGHT_CYAN',
65             'BRIGHT_MAGENTA',
66             'BRIGHT_BLUE'
67             ],
68             timeColors=>[
69             'GREEN',
70             'BRIGHT_GREEN',
71             'RED',
72             'BRIGHT_RED'
73             ],
74             processColor=>'WHITE',
75             fields=>[
76             'pid',
77             'uid',
78             'pctcpu',
79             'pctmem',
80             'size',
81             'rss',
82             'info',
83             'nice',
84             'start',
85             'time',
86             'proc',
87             ],
88             header=>1,
89             search=>undef,
90             resolveUser=>1,
91             nextColor=>0,
92             showIdle=>0,
93             proc_search=>undef,
94             user_search=>[],
95             wait_search=>[],
96             self_ignore=>2,
97             zombie_search=>0,
98             swapped_out_search=>0,
99             time_search=>[],
100             pctcpu_search=>[],
101             };
102             bless $self;
103             return $self;
104             }
105              
106             =head2 colorize
107              
108             This colorizes it and returns a setup Text::Table object with everything already setup.
109              
110             use Proc::ProcessTable::Colorizer;
111             my $cps = Proc::ProcessTable::Colorizer->new;
112             print $cps->colorize;
113              
114             =cut
115              
116             sub colorize{
117             my $self=$_[0];
118             $self->errorblank;
119              
120             #the feilds to use
121             my $fields=$self->fieldsGet;
122              
123             #array of colored items
124             my @colored;
125              
126             #
127             my $fieldInt=0;
128             my $header;
129             if ( $self->{header} ){
130             my @header;
131             while ( defined( $fields->[$fieldInt] ) ){
132             my $field=color('underline white');
133              
134             if ( $fields->[$fieldInt] eq 'pid' ){
135             $field=$field.'PID';
136             }elsif( $fields->[$fieldInt] eq 'uid' ){
137             $field=$field.'User';
138             }elsif( $fields->[$fieldInt] eq 'pctcpu' ){
139             $field=$field.'CPU%';
140             }elsif( $fields->[$fieldInt] eq 'pctmem' ){
141             $field=$field.'Mem%';
142             }elsif( $fields->[$fieldInt] eq 'size' ){
143             $field=$field.'VM Size';
144             }elsif( $fields->[$fieldInt] eq 'rss' ){
145             $field=$field.'RSS';
146             }elsif( $fields->[$fieldInt] eq 'proc' ){
147             $field=$field.'Command';
148             }else{
149             $field=$field.ucfirst($fields->[$fieldInt]);
150             }
151            
152             push( @header, $field.color('reset') );
153              
154             $fieldInt++;
155             }
156              
157             push( @colored, \@header );
158             }
159              
160             #get the process table
161             my $pt=Proc::ProcessTable->new;
162              
163             #an array of procs
164             my @procs;
165            
166             #goes through it all and gathers the information
167             foreach my $proc ( @{$pt->table} ){
168            
169             #process the requested fields
170             $fieldInt=0;
171             my %values;
172             while ( defined( $fields->[$fieldInt] ) ){
173             my $field=$fields->[$fieldInt];
174            
175             if (
176             ($^O =~ /bsd/) &&
177             ( $field =~ /pctcpu/ )
178             ){
179              
180             my $bproc=BSD::Process::info( $proc->pid );
181             my $pctcpu=$bproc->{pctcpu};
182              
183             if ( ! defined( $pctcpu ) ){
184             $values{pctcpu}=0
185             }else{
186             my $fscale=`/sbin/sysctl -a kern.fscale`;
187             $fscale=~s/^.*\: //;
188             chomp($fscale);
189            
190             $values{pctcpu}= 100 * ( $pctcpu / $fscale );
191             }
192             }elsif(
193             ($^O =~ /bsd/) &&
194             ( $field =~ /pctmem/ )
195             ){
196             use BSD::Process;
197             my $bproc=BSD::Process::info( $proc->pid );
198             my $rss=$bproc->{rssize};
199             if ( defined( $rss ) ){
200             $rss=$rss*1024*4;
201            
202             my $physmem=`/sbin/sysctl -a hw.physmem`;
203             chomp($physmem);
204             $physmem=~s/^.*\: //;
205            
206             $values{pctmem}=($rss / $physmem)*100;
207             }else{
208             $values{pctmem}=0;
209             }
210             }elsif(
211             ($^O =~ /bsd/) &&
212             ( $field =~ /size/ )
213             ){
214            
215             my $bproc=BSD::Process::info( $proc->pid );
216             $values{size}=$bproc->{size};
217             }elsif(
218             ($^O =~ /bsd/) &&
219             ( $field =~ /rss/ )
220             ){
221             $values{rss}=$proc->{rssize};
222             if (!defined $values{rss} ){
223             $values{rss}=0;
224             }else{
225             #not sure why this needs done :/
226             $values{rss}=$values{rss}*4;
227             }
228             }elsif(
229             $field eq 'proc'
230             ){
231             my $fname=$proc->fname;
232             my $cmndline=$proc->cmndline;
233              
234             #save it for possible future use
235             $values{fname}=$fname;
236             $values{cmndline}=$cmndline;
237              
238             #set the proc value
239             if ( $cmndline =~ /^$/ ){
240             my $kernel_proc=1; #just assuming yet, unless it is otherwise
241              
242             #may possible be a zombie, run checks for on FreeBSD
243             if ($^O =~ /bsd/){
244             my $bproc=BSD::Process::info( $proc->pid );
245             $kernel_proc=$bproc->{kthread};
246              
247             }
248              
249             #need to find something similar as above for Linux
250            
251             #
252             if ( $kernel_proc ){
253             $values{'proc'}='['.$fname.']';
254             if ( $fname eq 'idle' ){
255             $values{'idle'}=1;
256             }
257             }else{
258             #most likely a zombie
259             $values{'proc'}=$fname;
260             }
261             }else{
262             if ( $cmndline =~ /^su *$/ ){
263             $values{'proc'}=$cmndline.'('.$fname.')';
264             }else{
265             $values{'proc'}=$cmndline;
266             }
267             }
268             }elsif(
269             $field eq 'info'
270             ){
271             $values{wchan}=$proc->wchan;
272             $values{state}=$proc->state;
273              
274             if ($^O =~ /bsd/){
275             my $bproc=BSD::Process::info( $proc->pid );
276             $values{controlling_tty_active}=$bproc->{isctty};
277             $values{is_session_leader}=$bproc->{issleader};
278             $values{is_being_forked}=$bproc->{stat_1};
279             $values{working_on_exiting}=$bproc->{wexit};
280             $values{has_controlling_terminal}=$bproc->{controlt};
281             $values{is_locked}=$bproc->{locked};
282             $values{traced_by_debugger}=$bproc->{traced};
283             $values{is_stopped}=$bproc->{stat_4};
284             $values{posix_advisory_lock}=$bproc->{advlock};
285              
286             }
287            
288             }else{
289             $values{$field}=$proc->$field;
290             }
291              
292            
293             $fieldInt++;
294             }
295              
296             if ( ! defined( $values{pctmem} ) ){
297             $values{pctmem} = 0;
298             }
299             if ( ! defined( $values{pctcpu} ) ){
300             $values{pctcpu} = 0;
301             }
302              
303             if ( ! defined( $values{size} ) ){
304             $values{size} = 0;
305             }
306            
307             $values{pctmem}=sprintf('%.2f', $values{pctmem});
308             $values{pctcpu}=sprintf('%.2f', $values{pctcpu});
309              
310             $values{size}=$values{size}/1024;
311              
312             push( @procs, \%values );
313            
314             }
315              
316             #sort by CPU percent and then RAM
317             @procs=sort {
318             $a->{pctcpu} <=> $b->{pctcpu} or
319             $a->{pctmem} <=> $b->{pctmem} or
320             $a->{rss} <=> $b->{rss} or
321             $a->{size} <=> $b->{size} or
322             $a->{time} <=> $b->{time}
323             } @procs;
324             @procs=reverse(@procs);
325              
326             #put together the colored colums, minus the proc column which will be done later
327             my @proc_column;
328             foreach my $proc (@procs){
329             my @line;
330             $self->nextColorReset;
331              
332             my $show=0;
333              
334             #checks if it is the idle proc and if it should show it
335             if (
336             defined ( $proc->{idle} ) &&
337             ( ! $self->{showIdle} )
338             ){
339             $show = 0;
340             }else{
341             my $required_hits=0; #number of hits required to print it
342             my $hits=0; #default to zero so we print it unless we increment this for a search item
343              
344             #checks if we need to do a proc search
345             my $proc_search=$self->{proc_search};
346             if ( defined( $proc_search ) ){
347             $required_hits++;
348             #cehck if the cmndline or fname matches
349             if ( $proc->{proc} =~ /$proc_search/ ){
350             $hits++;
351             }
352             }
353              
354             #checks to see if it should ignore its self
355             my $self_ignore=$self->{self_ignore};
356             if (
357             #if it is set to 1
358             ( $self_ignore == 1 ) &&
359             ( $proc->{pid} == $$ )
360             ){
361             $required_hits++;
362             }elsif(
363             #if it is set to 2... we only care if we are doing a search...
364             #meaning required hits are greater than zero
365             ( $required_hits > 0 ) &&
366             ( $self_ignore == 2 ) &&
367             ( $proc->{pid} == $$ )
368             ){
369             #increment this so it will always be off by one for this proc, meaning it is ignored
370             $required_hits++;
371             }
372              
373             #check to see if it needs to search for users
374             my $user_search_array=$self->userSearchGet;
375             if ( defined( $user_search_array->[0] ) ){
376             my $user=getpwuid($proc->{uid});
377             $required_hits++;
378             my $user_search_int=0;
379             my $matched=0;
380             #search while we have a user defined and it has not already been matched
381             while(
382             defined( $user_search_array->[ $user_search_int ] ) &&
383             ( $matched == 0 )
384             ){
385             my $to_match=$user_search_array->[ $user_search_int ];
386             my $to_invert=0;
387             if ( $to_match=~ /^\!/ ){
388             $to_invert=1;
389             $to_match=~s/^\!//;
390             }
391              
392             #check if it matches
393             if ( $to_invert ){
394             if ( $to_match ne $user ){
395             $hits++;
396             $matched=1;
397             }
398             }else{
399             if ( $to_match eq $user ){
400             $hits++;
401             $matched=1;
402             }
403             }
404            
405             $user_search_int++;
406             }
407            
408             }
409              
410             #check to see if it needs to search for wait channels
411             my $wait_search_array=$self->waitSearchGet;
412             if ( defined( $wait_search_array->[0] ) ){
413             $required_hits++;
414             my $wait_search_int=0;
415             my $matched=0;
416             #search while we have a wait channel defined and it has not already been matched
417             while(
418             defined( $wait_search_array->[ $wait_search_int ] ) &&
419             ( $matched == 0 )
420             ){
421             my $to_match=$wait_search_array->[ $wait_search_int ];
422             my $to_invert=0;
423             if ( $to_match=~ /^\!/ ){
424             $to_invert=1;
425             $to_match=~s/^\!//;
426             }
427              
428             #check if it matches
429             if ( $to_invert ){
430             if ( $to_match ne $proc->{wchan} ){
431             $hits++;
432             $matched=1;
433             }
434             }else{
435             if ( $to_match eq $proc->{wchan} ){
436             $hits++;
437             $matched=1;
438             }
439             }
440            
441             $wait_search_int++;
442             }
443            
444             }
445              
446             #check to see if it needs to search for CPU time usage
447             my $time_search_array=$self->timeSearchGet;
448             if ( defined( $time_search_array->[0] ) ){
449             $required_hits++;
450             my $time_search_int=0;
451             my $matched=0;
452             #search while we have a CPU time defined and it has not already been matched
453             while(
454             defined( $time_search_array->[ $time_search_int ] ) &&
455             ( $matched == 0 )
456             ){
457             my $checked=0;
458             my $to_match=$time_search_array->[ $time_search_int ];
459             my $time=$proc->{time};
460             #checks for less than or equal
461             if (
462             ( $to_match =~ /^\<\=/ ) &&
463             ( $checked == 0 )
464             ){
465             $checked++;
466             $to_match =~ s/^\<\=//;
467             if ( $time <= $to_match ){
468             $hits++;
469             $matched++;
470             }
471             }
472              
473             #checks for less than
474             if (
475             ( $to_match =~ /^\
476             ( $checked == 0 )
477             ){
478             $checked++;
479             $to_match =~ s/^\
480             if ( $time < $to_match ){
481             $hits++;
482             $matched++;
483             }
484             }
485              
486             #checks for greater than or equal
487             if (
488             ( $to_match =~ /^\>=/ ) &&
489             ( $checked == 0 )
490             ){
491             $checked++;
492             $to_match =~ s/^\>\=//;
493             if ( $time >= $to_match ){
494             $hits++;
495             $matched++;
496             }
497             }
498              
499             #checks for greater than
500             if (
501             ( $to_match =~ /^\>/ ) &&
502             ( $checked == 0 )
503             ){
504             $checked++;
505             $to_match =~ s/^\>//;
506             if ( $time > $to_match ){
507             $hits++;
508             $matched++;
509             }
510             }
511            
512             $time_search_int++;
513             }
514            
515             }
516              
517             #check to see if it needs to search for CPU percent
518             my $pctcpu_search_array=$self->pctcpuSearchGet;
519             if ( defined( $pctcpu_search_array->[0] ) ){
520             $required_hits++;
521             my $pctcpu_search_int=0;
522             my $matched=0;
523             #search while we have a CPU usage defined and it has not already been matched
524             while(
525             defined( $pctcpu_search_array->[ $pctcpu_search_int ] ) &&
526             ( $matched == 0 )
527             ){
528             my $checked=0;
529             my $to_match=$pctcpu_search_array->[ $pctcpu_search_int ];
530             my $time=$proc->{pctcpu};
531             #checks for less than or equal
532             if (
533             ( $to_match =~ /^\<\=/ ) &&
534             ( $checked == 0 )
535             ){
536             $checked++;
537             $to_match =~ s/^\<\=//;
538             if ( $time <= $to_match ){
539             $hits++;
540             $matched++;
541             }
542             }
543              
544             #checks for less than
545             if (
546             ( $to_match =~ /^\
547             ( $checked == 0 )
548             ){
549             $checked++;
550             $to_match =~ s/^\
551             if ( $time < $to_match ){
552             $hits++;
553             $matched++;
554             }
555             }
556              
557             #checks for greater than or equal
558             if (
559             ( $to_match =~ /^\>=/ ) &&
560             ( $checked == 0 )
561             ){
562             $checked++;
563             $to_match =~ s/^\>\=//;
564             if ( $time >= $to_match ){
565             $hits++;
566             $matched++;
567             }
568             }
569              
570             #checks for greater than
571             if (
572             ( $to_match =~ /^\>/ ) &&
573             ( $checked == 0 )
574             ){
575             $checked++;
576             $to_match =~ s/^\>//;
577             if ( $time > $to_match ){
578             $hits++;
579             $matched++;
580             }
581             }
582            
583             $pctcpu_search_int++;
584             }
585             }
586              
587             #check to see if it needs to search for memory percent
588             my $pctmem_search_array=$self->pctmemSearchGet;
589             if ( defined( $pctmem_search_array->[0] ) ){
590             $required_hits++;
591             my $pctmem_search_int=0;
592             my $matched=0;
593             #search while we have a memory usage defined and it has not already been matched
594             while(
595             defined( $pctmem_search_array->[ $pctmem_search_int ] ) &&
596             ( $matched == 0 )
597             ){
598             my $checked=0;
599             my $to_match=$pctmem_search_array->[ $pctmem_search_int ];
600             my $pctmem=$proc->{pctmem};
601             #checks for less than or equal
602             if (
603             ( $to_match =~ /^\<\=/ ) &&
604             ( $checked == 0 )
605             ){
606             $checked++;
607             $to_match =~ s/^\<\=//;
608             if ( $pctmem <= $to_match ){
609             $hits++;
610             $matched++;
611             }
612             }
613              
614             #checks for less than
615             if (
616             ( $to_match =~ /^\
617             ( $checked == 0 )
618             ){
619             $checked++;
620             $to_match =~ s/^\
621             if ( $pctmem < $to_match ){
622             $hits++;
623             $matched++;
624             }
625             }
626              
627             #checks for greater than or equal
628             if (
629             ( $to_match =~ /^\>=/ ) &&
630             ( $checked == 0 )
631             ){
632             $checked++;
633             $to_match =~ s/^\>\=//;
634             if ( $pctmem >= $to_match ){
635             $hits++;
636             $matched++;
637             }
638             }
639              
640             #checks for greater than
641             if (
642             ( $to_match =~ /^\>/ ) &&
643             ( $checked == 0 )
644             ){
645             $checked++;
646             $to_match =~ s/^\>//;
647             if ( $pctmem > $to_match ){
648             $hits++;
649             $matched++;
650             }
651             }
652            
653             $pctmem_search_int++;
654             }
655             }
656            
657             #show zombie procs
658             if ( $self->{zombie_search} ){
659             $required_hits++;
660             if ( $proc->{state} eq 'zombie' ){
661             $hits++;
662             }
663             }
664              
665             #show swapped out procs
666             if ( $self->{swapped_out_search} ){
667             $required_hits++;
668             if (
669             ( $proc->{state} ne 'zombie' ) &&
670             ( $proc->{rss} == '0' )
671             ){
672             $hits++;
673             }
674             }
675            
676             if ( $required_hits == $hits ){
677             $show=1;
678             }
679             }
680              
681             if (
682             ( $show )
683             ){
684            
685             foreach my $field ( @{$fields} ){
686             my $item='';
687             if ( defined( $proc->{$field} ) ){
688             $item=$proc->{$field};
689             }
690             #we will add proc later once we know the size of the table
691             if ($field ne 'proc'){
692             if ( $field eq 'start' ){
693             $item=$self->startString($item);
694             }
695            
696             if (
697             ( $field eq 'uid' ) &&
698             $self->{resolveUser}
699             ){
700             $item=getpwuid($item);
701             }
702            
703             #colorizes it
704             if ( $field eq 'time' ){
705             $item=$self->timeString($item);
706             }elsif( $field eq 'proc' ){
707             $item=color($self->processColorGet).$item;
708             }elsif( $field eq 'info'){
709             my $left=$proc->{state};
710             if (
711             $left eq 'sleep'
712             ){
713             $left='S';
714             }elsif(
715             $left eq 'zombie'
716             ){
717             $left='Z';
718             }elsif(
719             $left eq 'wait'
720             ){
721             $left='W';
722             }elsif(
723             $left eq 'run'
724             ){
725             $left='R';
726             }
727            
728             #checks if it is swapped out
729             if (
730             ( $proc->{state} ne 'zombie' ) &&
731             ( $proc->{rss} == '0' )
732             ){
733             $left=$left.'O';
734             }
735            
736             #waiting to exit
737             if (
738             ( defined( $proc->{working_on_exiting} ) ) &&
739             $proc->{working_on_exiting}
740             ){
741             $left=$left.'E';
742             }
743            
744             #session leader
745             if (
746             ( defined( $proc->{is_session_leader} ) ) &&
747             $proc->{is_session_leader}
748             ){
749             $left=$left.'s';
750             }
751            
752             #checks to see if any sort of locks are present
753             if (
754             ( defined( $proc->{is_locked} ) || defined( $proc->{posix_advisory_lock} ) )&&
755             ( $proc->{is_locked} || $proc->{posix_advisory_lock} )
756             ){
757             $left=$left.'L';
758             }
759            
760             #checks to see if has a controlling terminal
761             if (
762             ( defined( $proc->{has_controlling_terminal} ) ) &&
763             $proc->{has_controlling_terminal}
764             ){
765             $left=$left.'+';
766             }
767              
768             #if it is being forked
769             if (
770             ( defined( $proc->{is_being_forked} ) ) &&
771             $proc->{is_being_forked}
772             ){
773             $left=$left.'F';
774             }
775            
776             #checks if it knows it is being traced
777             if (
778             ( defined( $proc->{traced_by_debugger} ) ) &&
779             $proc->{traced_by_debugger}
780             ){
781             $left=$left.'X';
782             }
783            
784             $item=color($self->nextColor).$left.' '.color($self->nextColor).$proc->{wchan};
785            
786             }else{
787             $item=color($self->nextColor).$item;
788             }
789              
790             push( @line, $item.color('reset') );
791             }else{
792             push( @proc_column, $item );
793             }
794             }
795            
796             push( @colored, \@line );
797             }
798             }
799              
800             #get table width info
801             my $tb = Text::Table->new;
802             $tb->load( @colored );
803             my $width=$tb->width;
804             my ($columns, $rows) = Term::Size::chars *STDOUT{IO};
805             $tb->clear;
806              
807             #add 120 as Text::Table appears to be off by that much
808             $columns=$columns+128;
809              
810             #this is
811             my $procwidth=$columns-$width;
812              
813             #process each colored item and shove the proc info in
814             my $colored_int=1;
815             my $proc_column_int=0;
816             while ( defined( $colored[$colored_int] ) ){
817             my $item=$proc_column[$proc_column_int];
818             #remove all the newlines
819             $item=~s/\n//g;
820              
821             $item=substr( $item, 0, $procwidth);
822              
823             push( @{$colored[$colored_int]}, $item );
824              
825             $proc_column_int++;
826             $colored_int++;
827             }
828            
829             return $tb->load( @colored );
830             }
831              
832             =head2 fields
833              
834             Gets a hash of possible fields from Proc::ProcessTable as an hash.
835              
836             This is really meant as a internal function.
837              
838             =cut
839              
840             sub fields{
841             my $self=$_[0];
842             $self->errorblank;
843              
844             my $p=Proc::ProcessTable->new;
845             my @fields=$p->fields;
846              
847             my $int=0;
848             my %toReturn;
849             while( defined($fields[$int]) ){
850             $toReturn{$fields[$int]}=1;
851            
852             $int++;
853             }
854              
855             return %toReturn;
856             }
857              
858             =head2 fieldsGet
859              
860             Gets the currently set fields.
861              
862             Returns a array ref of current fields to be printed.
863              
864             my $fields=$cps->fieldsGet;
865              
866             =cut
867              
868             sub fieldsGet{
869             my $self=$_[0];
870             $self->errorblank;
871              
872             return $self->{fields};
873             }
874              
875             =head2 nextColor
876              
877             Returns the next color.
878              
879             my $nextColor=$cps->nextColor;
880              
881             =cut
882              
883             sub nextColor{
884             my $self=$_[0];
885             $self->errorblank;
886              
887             my $color;
888            
889             if( defined( $self->{colors}[ $self->{nextColor} ] ) ){
890             $color=$self->{colors}[ $self->{nextColor} ];
891             $self->{nextColor}++;
892             }else{
893             $self->{nextColor}=0;
894             $color=$self->{colors}[ $self->{nextColor} ];
895             $self->{nextColor}++;
896             }
897              
898             return $color;
899             }
900              
901             =head2 nextColor
902              
903             Resets the next color to the first one.
904              
905             my $nextColor=$cps->nextColor;
906              
907             =cut
908              
909             sub nextColorReset{
910             my $self=$_[0];
911             $self->errorblank;
912              
913             $self->{nextColor}=0;
914              
915             return 1;
916             }
917              
918             =head2 fieldsSet
919              
920             Gets the currently set fields.
921              
922             Returns a list of current fields to be printed.
923              
924             my @fields=$cps->fieldsGet;
925              
926             =cut
927              
928             sub fieldsSet{
929             my $self=$_[0];
930             $self->errorblank;
931              
932              
933             }
934              
935             =head2 pctcpuSearchGet
936              
937             Returns the current value for the PCT CPU search.
938              
939             The return is a array ref.
940              
941             my $pctcpu_search=$cps->pctcpuSearchGet;
942              
943             =cut
944              
945             sub pctcpuSearchGet{
946             my $self=$_[0];
947             $self->errorblank;
948              
949             return $self->{pctcpu_search};
950             }
951              
952             =head2 pctcpuSearchSetString
953              
954             Search for procs based on the CPU usage.
955              
956             The following equalities are understood.
957              
958             <=
959             <
960             >
961             >=
962              
963             The string may contain multiple values seperated by a comma. Checking will stop after the first hit.
964              
965             If the string is undef, all procs will be shown.
966              
967             #search for procs with less than 60% of CPU usage
968             $cps->pctcpuSearchSetString('<60');
969             #shows procs with greater than 60% of CPU usage
970             $cps->pctcpuSearchSetString('>60');
971              
972             =cut
973              
974             sub pctcpuSearchSetString{
975             my $self=$_[0];
976             my $pctcpu_search_string=$_[1];
977             $self->errorblank;
978              
979             my @pctcpu_search_array;
980             if ( ! defined( $pctcpu_search_string ) ){
981             $self->{pctcpu_search}=\@pctcpu_search_array;
982             }else{
983             @pctcpu_search_array=split(/\,/, $pctcpu_search_string);
984              
985             foreach my $item ( @pctcpu_search_array ){
986             if (
987             ( $item !~ /^\>[0123456789]*$/ ) &&
988             ( $item !~ /^\>=[0123456789]*$/ ) &&
989             ( $item !~ /^\<[0123456789]*$/ ) &&
990             ( $item !~ /^\<=[0123456789]*$/ )
991             ){
992             $self->{error}=2;
993             $self->{errorString}='"'.$item.'"" is not a valid value for use in a PCT CPU search';
994             $self->warn;
995             return undef;
996             }
997            
998             }
999            
1000             $self->{pctcpu_search}=\@pctcpu_search_array;
1001             }
1002              
1003             return 1;
1004             }
1005              
1006             =head2 pctmemSearchGet
1007              
1008             Returns the current value for the PCT MEM search.
1009              
1010             The return is a array ref.
1011              
1012             my $pctmem_search=$cps->pctmemSearchGet;
1013              
1014             =cut
1015              
1016             sub pctmemSearchGet{
1017             my $self=$_[0];
1018             $self->errorblank;
1019              
1020             return $self->{pctmem_search};
1021             }
1022              
1023             =head2 pctmemSearchSetString
1024              
1025             Search for procs based on the memory usage.
1026              
1027             The following equalities are understood.
1028              
1029             <=
1030             <
1031             >
1032             >=
1033              
1034             The string may contain multiple values seperated by a comma. Checking will stop after the first hit.
1035              
1036             If the string is undef, all procs will be shown.
1037              
1038             #search for procs with less than 60% of the memory
1039             $cps->pctmemSearchSetString('<60');
1040             #shows procs with greater than 60% of the memory
1041             $cps->pctmemSearchSetString('>60');
1042              
1043             =cut
1044              
1045             sub pctmemSearchSetString{
1046             my $self=$_[0];
1047             my $pctmem_search_string=$_[1];
1048             $self->errorblank;
1049              
1050             my @pctmem_search_array;
1051             if ( ! defined( $pctmem_search_string ) ){
1052             $self->{pctmem_search}=\@pctmem_search_array;
1053             }else{
1054             @pctmem_search_array=split(/\,/, $pctmem_search_string);
1055              
1056             foreach my $item ( @pctmem_search_array ){
1057             if (
1058             ( $item !~ /^\>[0123456789]*$/ ) &&
1059             ( $item !~ /^\>=[0123456789]*$/ ) &&
1060             ( $item !~ /^\<[0123456789]*$/ ) &&
1061             ( $item !~ /^\<=[0123456789]*$/ )
1062             ){
1063             $self->{error}=3;
1064             $self->{errorString}='"'.$item.'"" is not a valid value for use in a PCT MEM search';
1065             $self->warn;
1066             return undef;
1067             }
1068            
1069             }
1070            
1071             $self->{pctmem_search}=\@pctmem_search_array;
1072             }
1073              
1074             return 1;
1075             }
1076              
1077             =head2 processColorGet
1078              
1079             my $timeColors=$cps->processColorGet;
1080              
1081             =cut
1082              
1083             sub processColorGet{
1084             my $self=$_[0];
1085             $self->errorblank;
1086              
1087             return $self->{processColor};
1088             }
1089              
1090             =head2 procSearchGet
1091              
1092             This returns the search string value that will be used
1093             for matching the proc column.
1094              
1095             The return is undefined if one is not set.
1096              
1097             my $search_regex=$cps->procSearchGet;
1098             if ( defined( $search_regex ) ){
1099             print "search regex: ".$search_regex."\n";
1100             }else{
1101             print "No search regex.\n";
1102             }
1103              
1104             =cut
1105              
1106             sub procSearchGet{
1107             my $self=$_[0];
1108             $self->errorblank;
1109              
1110             return $self->{proc_search};
1111             }
1112              
1113             =head2 procSearchSet
1114              
1115             This sets the proc column search regex to use.
1116              
1117             If set to undef(the default), then it will show all procs.
1118              
1119             #shows everything
1120             $cps->procSearchSet( undef );
1121              
1122             #search for only those matching musicpd
1123             $cps->procSeearchSet( 'musicpd' );
1124              
1125             #search for those that match /[Zz]whatever/
1126             $cps->procSearchSet( '[Zz]whatever' );
1127              
1128             =cut
1129              
1130             sub procSearchSet{
1131             my $self=$_[0];
1132             my $proc_search=$_[1];
1133             $self->errorblank;
1134              
1135             $self->{proc_search}=$proc_search;
1136            
1137             return 1;
1138             }
1139              
1140             =head2 selfIgnoreGet
1141              
1142             =cut
1143              
1144             sub selfIgnoreGet{
1145             my $self=$_[0];
1146             $self->errorblank;
1147              
1148             return $self->{self_ignore};
1149             }
1150              
1151             =head2 selfIgnoreSet
1152              
1153             Wether or not to show the PID of this processes in the list.
1154              
1155             =head3 undef
1156              
1157             Resets it to the default, 2.
1158              
1159             =head3 0
1160              
1161             Always show self PID in the list.
1162              
1163             =head3 1
1164              
1165             Never show self PID in the list.
1166              
1167             =head3 2
1168              
1169             Don't show self PID if it is a search.
1170              
1171             This is the default.
1172              
1173             =cut
1174              
1175             sub selfIgnoreSet{
1176             my $self=$_[0];
1177             my $self_ignore=$_[1];
1178             $self->errorblank;
1179              
1180             if ( ! defined( $self_ignore ) ){
1181             $self_ignore='2';
1182             }
1183            
1184             $self->{self_ignore}=$self_ignore;
1185            
1186             return 1;
1187             }
1188              
1189             =head2 startString
1190              
1191             Generates a short time string based on the supplied unix time.
1192              
1193             =cut
1194              
1195             sub startString{
1196             my $self=$_[0];
1197             my $startTime=$_[1];
1198             $self->errorblank;
1199              
1200             my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($startTime);
1201             my ($csec,$cmin,$chour,$cmday,$cmon,$cyear,$cwday,$cyday,$cisdst) = localtime(time);
1202              
1203             #add the required stuff to make this sane
1204             $year += 1900;
1205             $cyear += 1900;
1206             $mon += 1;
1207             $cmon += 1;
1208            
1209             #find the most common one and return it
1210             if ( $year ne $cyear ){
1211             return $year.sprintf('%02d', $mon).sprintf('%02d', $mday).'-'/sprintf('%02d', $hour).':'.sprintf('%02d', $min);
1212             }
1213             if ( $mon ne $cmon ){
1214             return sprintf('%02d', $mon).sprintf('%02d', $mday).'-'.sprintf('%02d', $hour).':'.sprintf('%02d', $min);
1215             }
1216             if ( $mday ne $cmday ){
1217             return sprintf('%02d', $mday).'-'.sprintf('%02d', $hour).':'.sprintf('%02d', $min);
1218             }
1219              
1220             #just return this for anything less
1221             return sprintf('%02d', $hour).':'.sprintf('%02d', $min);
1222             }
1223              
1224             =head2 swappedOutSearchGet
1225              
1226             Returns the current value for the swapped out search.
1227              
1228             The return is a Perl boolean.
1229              
1230             my $swappedOut_search=$cps->swappedOutSearchGet;
1231             if ( $swappedOut_search ){
1232             print "only swapped out procs will be shown";
1233             }
1234              
1235             =cut
1236              
1237             sub swappedOutSearchGet{
1238             my $self=$_[0];
1239             $self->errorblank;
1240              
1241             return $self->{swapped_out_search};
1242             }
1243              
1244             =head2 swappedOutSearchSet
1245              
1246             Sets the swapped out search value.
1247              
1248             The value taken is a Perl boolean.
1249              
1250             $cps->swappedOutSearchSet( 1 );
1251              
1252             =cut
1253              
1254             sub swappedOutSearchSet{
1255             my $self=$_[0];
1256             my $swapped_out_search=$_[1];
1257             $self->errorblank;
1258              
1259             $self->{swapped_out_search}=$swapped_out_search;
1260              
1261             return 1;
1262             }
1263              
1264             =head2 timeColorsGet
1265              
1266             my $timeColors=$cps->timeColorsGet;
1267              
1268             =cut
1269              
1270             sub timeColorsGet{
1271             my $self=$_[0];
1272             $self->errorblank;
1273              
1274             return $self->{timeColors};
1275             }
1276              
1277             =head2 timeSearchGet
1278              
1279             Returns the current value for the time search.
1280              
1281             The return is a array ref.
1282              
1283             my $time_search=$cps->waitSearchGet;
1284              
1285             =cut
1286              
1287             sub timeSearchGet{
1288             my $self=$_[0];
1289             $self->errorblank;
1290              
1291             return $self->{time_search};
1292             }
1293              
1294             =head2 timeSearchSetString
1295              
1296             Search for procs based on the CPU time value.
1297              
1298             The following equalities are understood.
1299              
1300             <=
1301             <
1302             >
1303             >=
1304              
1305             The string may contain multiple values seperated by a comma. Checking will stop after the first hit.
1306              
1307             If the string is undef, all wait channels will be shown.
1308              
1309             #search for procs with less than 60 seconds of CPU time
1310             $cps->waitSearchSetString('<69');
1311             #shows procs with less than 60 seconds and greater 120 seconds
1312             $cps->waitSearchSetString('<60,>120');
1313              
1314             =cut
1315              
1316             sub timeSearchSetString{
1317             my $self=$_[0];
1318             my $time_search_string=$_[1];
1319             $self->errorblank;
1320              
1321             my @time_search_array;
1322             if ( ! defined( $time_search_string ) ){
1323             $self->{time_search}=\@time_search_array;
1324             }else{
1325             @time_search_array=split(/\,/, $time_search_string);
1326              
1327             foreach my $item ( @time_search_array ){
1328             if (
1329             ( $item !~ /^\>[0123456789]*$/ ) &&
1330             ( $item !~ /^\>=[0123456789]*$/ ) &&
1331             ( $item !~ /^\<[0123456789]*$/ ) &&
1332             ( $item !~ /^\<=[0123456789]*$/ )
1333             ){
1334             $self->{error}=1;
1335             $self->{errorString}='"'.$item.'"" is not a valid value for use in a time search';
1336             $self->warn;
1337             return undef;
1338             }
1339            
1340             }
1341            
1342             $self->{time_search}=\@time_search_array;
1343             }
1344              
1345             return 1;
1346             }
1347              
1348             =head2 timeString
1349              
1350             Turns the raw run string into something usable.
1351              
1352             This returns a colorized item.
1353              
1354             my $time=$cps->timeString( $seconds );
1355              
1356             =cut
1357              
1358             sub timeString{
1359             my $self=$_[0];
1360             my $time=$_[1];
1361             $self->errorblank;
1362              
1363             my $colors=$self->timeColorsGet;
1364              
1365             my $hours=0;
1366             if ( $time >= 3600 ){
1367             $hours = $time / 3600;
1368             }
1369             my $loSeconds = $time % 3600;
1370             my $minutes=0;
1371             if ( $time >= 60 ){
1372             $minutes = $loSeconds / 60;
1373             }
1374             my $seconds = $loSeconds % 60;
1375              
1376             #nicely format it
1377             $hours=~s/\..*//;
1378             $minutes=~s/\..*//;
1379             $seconds=sprintf('%.f',$seconds);
1380            
1381             #this will be returned
1382             my $toReturn='';
1383              
1384             #process the hours bit
1385             if ( $hours == 0 ){
1386             #don't do anything if time is 0
1387             }elsif(
1388             $hours >= 10
1389             ){
1390             $toReturn=color($colors->[3]).$hours.':';
1391             }else{
1392             $toReturn=color($colors->[2]).$hours.':';
1393             }
1394              
1395             #process the minutes bit
1396             if (
1397             ( $hours > 0 ) ||
1398             ( $minutes > 0 )
1399             ){
1400             $toReturn=$toReturn.color( $colors->[1] ). $minutes.':';
1401             }
1402              
1403             $toReturn=$toReturn.color( $colors->[0] ).$seconds;
1404            
1405             return $toReturn;
1406             }
1407              
1408             =head1 userSearchGet
1409              
1410             This gets the user to be searched for and if it should be inverted or not.
1411              
1412             This returns an array reference of users to search for.
1413              
1414             An selection can be inverted via !.
1415              
1416             my $user_search=$cps->userSearchGet;
1417              
1418             =cut
1419              
1420             sub userSearchGet{
1421             my $self=$_[0];
1422             $self->errorblank;
1423              
1424             return $self->{user_search};
1425             }
1426              
1427             =head1 userSearchSetString
1428              
1429             This takes a string to set the user search for.
1430              
1431             An selection can be inverted via !.
1432              
1433             The string may contain multiple users seperated by a comma.
1434              
1435             If the string is undef, all users will be shown.
1436              
1437             #search for user foo and bar
1438             $cps->userSearchSetString('foo,bar');
1439             #show users not matching foo
1440             $cps->userSearchSetString('!foo');
1441             #show all users, clearing any previous settings
1442             $cps->userSearchSetString;
1443              
1444             =cut
1445              
1446             sub userSearchSetString{
1447             my $self=$_[0];
1448             my $user_search_string=$_[1];
1449             $self->errorblank;
1450              
1451             my @user_search_array;
1452             if ( ! defined( $user_search_string ) ){
1453             $self->{user_search}=\@user_search_array;
1454             }else{
1455             @user_search_array=split(/\,/, $user_search_string);
1456             $self->{user_search}=\@user_search_array;
1457             }
1458              
1459             return 1;
1460             }
1461              
1462             =head2 waitSearchGet
1463              
1464             Returns the current value for the wait search.
1465              
1466             The return is a array ref.
1467              
1468             my $wait_search=$cps->waitSearchGet;
1469              
1470             =cut
1471              
1472             sub waitSearchGet{
1473             my $self=$_[0];
1474             $self->errorblank;
1475              
1476             return $self->{wait_search};
1477             }
1478              
1479             =head2 waitSearchSetString
1480              
1481             This takes a string to set the wait channel search for.
1482              
1483             An selection can be inverted via !.
1484              
1485             The string may contain multiple users seperated by a comma.
1486              
1487             If the string is undef, all wait channels will be shown.
1488              
1489             #search for wait channel wait and sleep
1490             $cps->waitSearchSetString('wait,sleep');
1491             #shows wait channels not matching sbwait
1492             $cps->waitSearchSetString('!sbwait');
1493             #show all users, clearing any previous settings
1494             $cps->waitSearchSetString;
1495              
1496             =cut
1497              
1498             sub waitSearchSetString{
1499             my $self=$_[0];
1500             my $wait_search_string=$_[1];
1501             $self->errorblank;
1502              
1503             my @wait_search_array;
1504             if ( ! defined( $wait_search_string ) ){
1505             $self->{wait_search}=\@wait_search_array;
1506             }else{
1507             @wait_search_array=split(/\,/, $wait_search_string);
1508             $self->{wait_search}=\@wait_search_array;
1509             }
1510              
1511             return 1;
1512             }
1513              
1514             =head2 zombieSearchGet
1515              
1516             Returns the current value for the zombie search.
1517              
1518             The return is a Perl boolean.
1519              
1520             my $zombie_search=$cps->zombieSearchGet;
1521             if ( $zombie_search ){
1522             print "only zombie procs will be shown";
1523             }
1524              
1525             =cut
1526              
1527             sub zombieSearchGet{
1528             my $self=$_[0];
1529             $self->errorblank;
1530              
1531             return $self->{zombie_search};
1532             }
1533              
1534             =head2 zombieSearchSet
1535              
1536             Sets the zombie search value.
1537              
1538             The value taken is a Perl boolean.
1539              
1540             $cps->zombieSearchSet( 1 );
1541              
1542             =cut
1543              
1544             sub zombieSearchSet{
1545             my $self=$_[0];
1546             my $zombie_search=$_[1];
1547             $self->errorblank;
1548              
1549             $self->{zombie_search}=$zombie_search;
1550              
1551             return 1;
1552             }
1553              
1554             =head1 COLORS
1555              
1556             These corresponds to L colors.
1557              
1558             =head2 Time
1559              
1560             The color column is not a single color, but multiple depending on the amount of time.
1561              
1562             The default is as below.
1563              
1564             'GREEN', seconds
1565             'BRIGHT_GREEN', minutes
1566             'RED', hours
1567             'BRIGHT_RED', 10+ hours
1568              
1569             =head2 Columns
1570              
1571             The non-proc/time columns are colored in a rotating color sequence.
1572              
1573             The default is as below.
1574              
1575             BRIGHT_YELLOW
1576             BRIGHT_CYAN
1577             BRIGHT_MAGENTA
1578             BRIGHT_BLUE
1579              
1580             =head1 ERROR CODES/FLAGS
1581              
1582             =head2 1 / badTimeString
1583              
1584             The time search string contains errors.
1585              
1586             =head2 2 / badPctcpuString
1587              
1588             The PCT CPU search string contains errors.
1589              
1590             =head2 3 / badPctmemString
1591              
1592             The PCT MEM search string contains errors.
1593              
1594             =head1 AUTHOR
1595              
1596             Zane C. Bowers-Hadley, C<< >>
1597              
1598             =head1 BUGS
1599              
1600             Please report any bugs or feature requests to C, or through
1601             the web interface at L. I will be notified, and then you'll
1602             automatically be notified of progress on your bug as I make changes.
1603              
1604              
1605              
1606              
1607             =head1 SUPPORT
1608              
1609             You can find documentation for this module with the perldoc command.
1610              
1611             perldoc Proc::ProcessTable::Colorizer
1612              
1613              
1614             You can also look for information at:
1615              
1616             =over 4
1617              
1618             =item * RT: CPAN's request tracker (report bugs here)
1619              
1620             L
1621              
1622             =item * AnnoCPAN: Annotated CPAN documentation
1623              
1624             L
1625              
1626             =item * CPAN Ratings
1627              
1628             L
1629              
1630             =item * Search CPAN
1631              
1632             L
1633              
1634             =back
1635              
1636              
1637             =head1 ACKNOWLEDGEMENTS
1638              
1639              
1640             =head1 LICENSE AND COPYRIGHT
1641              
1642             Copyright 2017 Zane C. Bowers-Hadley.
1643              
1644             This program is distributed under the (Simplified) BSD License:
1645             L
1646              
1647             Redistribution and use in source and binary forms, with or without
1648             modification, are permitted provided that the following conditions
1649             are met:
1650              
1651             * Redistributions of source code must retain the above copyright
1652             notice, this list of conditions and the following disclaimer.
1653              
1654             * Redistributions in binary form must reproduce the above copyright
1655             notice, this list of conditions and the following disclaimer in the
1656             documentation and/or other materials provided with the distribution.
1657              
1658             THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1659             "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1660             LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1661             A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1662             OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1663             SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1664             LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1665             DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1666             THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1667             (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1668             OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1669              
1670              
1671             =cut
1672              
1673             1; # End of Proc::ProcessTable::Colorizer