merge_attributes throw )
;
has
'cache_ttys'
=>
is
=>
'ro'
,
isa
=> Bool,
default
=> TRUE;
has
'config'
=>
is
=>
'ro'
,
isa
=> ConfigProvider,
required
=> TRUE;
has
'log'
=>
is
=>
'ro'
,
isa
=> Logger,
required
=> TRUE;
has
'table_class'
=>
is
=>
'lazy'
,
isa
=> LoadableClass,
coerce
=> TRUE,
default
=>
'Class::Usul::Response::Table'
;
my
$_cmd_matches
=
sub
{
my
(
$cmd
,
$pattern
) =
@_
;
return
!
$pattern
||
$cmd
=~ m{
$pattern
}msx ? TRUE : FALSE;
};
my
$_new_proc_process_table
=
sub
{
my
$cache_ttys
=
shift
;
can_load(
modules
=> {
'Proc::ProcessTable'
=>
'0'
} )
and
return
Proc::ProcessTable->new(
cache_ttys
=>
$cache_ttys
);
return
Class::Null->new;
};
my
$_new_process_table
=
sub
{
my
(
$class
,
$rows
,
$count
) =
@_
;
return
$class
->new
(
count
=>
$count
,
fields
=> [
qw( uid pid ppid start time size state tty cmd )
],
labels
=> {
uid
=>
'User'
,
pid
=>
'PID'
,
ppid
=>
'PPID'
,
start
=>
'Start Time'
,
tty
=>
'TTY'
,
time
=>
'Time'
,
size
=>
'Size'
,
state
=>
'State'
,
cmd
=>
'Command'
},
typelist
=> {
pid
=>
'numeric'
,
ppid
=>
'numeric'
,
start
=>
'date'
,
size
=>
'numeric'
,
time
=>
'numeric'
},
values
=>
$rows
,
wrap
=> {
cmd
=> 1 }, );
};
my
$_proc_belongs_to_user
=
sub
{
my
(
$puid
,
$user
) =
@_
;
return
(!
$user
||
$user
eq
'All'
||
$user
eq loginid
$puid
) ? TRUE : FALSE;
};
my
$_pscomp
=
sub
{
my
(
$arg1
,
$arg2
) =
@_
;
my
$result
;
$result
=
$arg1
->{uid} cmp
$arg2
->{uid};
$result
=
$arg1
->{pid} <=>
$arg2
->{pid}
if
(
$result
== 0);
return
$result
;
};
my
$_set_fields
=
sub
{
my
(
$has
,
$p
) =
@_
;
my
$flds
= {};
$flds
->{id } =
$has
->{pid } ?
$p
->pid : NUL;
$flds
->{pid } =
$has
->{pid } ?
$p
->pid : NUL;
$flds
->{ppid } =
$has
->{ppid } ?
$p
->ppid : NUL;
$flds
->{start} =
$has
->{start } ? time2str(
'%d/%m %H:%M'
,
$p
->start ) : NUL;
$flds
->{state} =
$has
->{state } ?
$p
->state : NUL;
$flds
->{tty } =
$has
->{ttydev} ?
$p
->ttydev : NUL;
$flds
->{
time
} =
$has
->{
time
} ?
int
$p
->
time
/ 1_000_000 : NUL;
$flds
->{uid } =
$has
->{uid } ?
getpwuid
$p
->uid : NUL;
if
(
$has
->{ttydev} and
$p
->ttydev) {
$flds
->{tty} =
$p
->ttydev;
}
elsif
(
$has
->{ttynum} and
$p
->ttynum) {
$flds
->{tty} =
$p
->ttynum;
}
else
{
$flds
->{tty} = NUL }
if
(
$has
->{rss} and
$p
->rss) {
$flds
->{size} =
int
$p
->rss/1_024;
}
elsif
(
$has
->{size} and
$p
->size) {
$flds
->{size} =
int
$p
->size/1_024;
}
else
{
$flds
->{size} = NUL }
if
(
$has
->{
exec
} and
$p
->
exec
) {
$flds
->{cmd} =
substr
$p
->
exec
, 0, 64;
}
elsif
(
$has
->{cmndline} and
$p
->cmndline) {
$flds
->{cmd} =
substr
$p
->cmndline, 0, 64;
}
elsif
(
$has
->{fname} and
$p
->fname) {
$flds
->{cmd} =
substr
$p
->fname, 0, 64;
}
else
{
$flds
->{cmd} = NUL }
return
$flds
;
};
my
$_signal_cmd
=
sub
{
my
(
$cmd
,
$flag
,
$sig
,
$pids
) =
@_
;
my
$opts
= [];
$sig
and
push
@{
$opts
},
'-o'
,
"sig=${sig}"
;
$flag
and
push
@{
$opts
},
'-o'
,
'flag=one'
;
return
[
$cmd
,
'-nc'
,
'signal_process'
, @{
$opts
},
'--'
, @{
$pids
|| [] } ];
};
around
'BUILDARGS'
=>
sub
{
my
(
$orig
,
$self
,
@args
) =
@_
;
my
$attr
=
$orig
->(
$self
,
@args
);
my
$builder
=
delete
$attr
->{builder} or
return
$attr
;
merge_attributes
$attr
,
$builder
, {}, [
'config'
,
'log'
];
return
$attr
;
};
sub
child_list {
my
(
$self
,
$pid
,
$procs
) =
@_
;
my
(
$child
,
$ppt
);
my
@pids
= ();
unless
(
defined
$procs
) {
$ppt
=
$_new_proc_process_table
->(
$self
->cache_ttys );
$procs
= {
map
{
$_
->
pid
=>
$_
->ppid } @{
$ppt
->table } };
}
if
(
exists
$procs
->{
$pid
}) {
for
$child
(
grep
{
$procs
->{
$_
} ==
$pid
}
keys
%{
$procs
}) {
push
@pids
,
$self
->child_list(
$child
,
$procs
);
}
push
@pids
,
$pid
;
}
return
sort
{
$a
<=>
$b
}
@pids
;
}
sub
list_pids_by_file_system {
my
(
$self
,
$fsystem
) =
@_
;
$fsystem
or
return
();
my
$opts
= {
err
=>
'null'
,
expected_rv
=> 1 };
my
$data
=
$self
->run_cmd(
"fuser ${fsystem}"
,
$opts
)->out || NUL;
$data
=~ s{ [^0-9\s] }{}gmx;
$data
=~ s{ \s+ }{ }gmx;
return
sort
{
$a
<=>
$b
}
grep
{
defined
&&
length
}
split
SPC,
$data
;
}
sub
popen {
return
shift
->run_cmd(
@_
);
}
sub
process_exists {
my
(
$self
,
@args
) =
@_
;
my
$args
= arg_list
@args
;
my
$pid
=
$args
->{pid};
my
(
$io
,
$file
);
$file
=
$args
->{file} and
$io
= io(
$file
) and
$io
->is_file
and
$pid
=
$io
->
chomp
->
lock
->getline;
(not
$pid
or
$pid
!~ m{ \d+ }mx) and
return
FALSE;
return
(CORE::
kill
0,
$pid
) ? TRUE : FALSE;
}
sub
process_table {
my
(
$self
,
@args
) =
@_
;
my
$args
= arg_list
@args
;
my
$pat
=
$args
->{pattern};
my
$ptype
=
$args
->{type } // 1;
my
$user
=
$args
->{user } // get_user->name;
my
$ppt
=
$_new_proc_process_table
->(
$self
->cache_ttys );
my
$has
= {
map
{
$_
=> TRUE }
$ppt
->fields };
my
@rows
= ();
my
$count
= 0;
if
(
$ptype
== 3) {
my
%procs
=
map
{
$_
->
pid
=>
$_
} @{
$ppt
->table };
my
@pids
=
$self
->list_pids_by_file_system(
$args
->{fsystem} );
for
my
$p
(
grep
{
defined
}
map
{
$procs
{
$_
} }
@pids
) {
push
@rows
,
$_set_fields
->(
$has
,
$p
);
$count
++;
}
}
else
{
for
my
$p
(@{
$ppt
->table }) {
if
( (
$ptype
== 1 and
$_proc_belongs_to_user
->(
$p
->uid,
$user
))
or (
$ptype
== 2 and
$_cmd_matches
->(
$p
->cmndline,
$pat
))) {
push
@rows
,
$_set_fields
->(
$has
,
$p
);
$count
++;
}
}
}
return
$_new_process_table
->
(
$self
->table_class, [
sort
{
$_pscomp
->(
$a
,
$b
) }
@rows
],
$count
);
}
sub
run_cmd {
my
(
$self
,
$cmd
,
@args
) =
@_
;
my
$attr
= arg_list
@args
;
$attr
->{cmd } =
$cmd
or throw Unspecified, [
'command'
];
$attr
->{
log
} =
$self
->
log
;
$attr
->{rundir } =
$self
->config->rundir;
$attr
->{tempdir} =
$self
->config->tempdir;
return
Class::Usul::IPC::Cmd->new(
$attr
)->run_cmd;
}
sub
signal_process {
my
(
$self
,
@args
) =
@_
;
is_hashref
$args
[ 0 ]
or
return
$self
->run_cmd(
$_signal_cmd
->(
$self
->config->suid,
@args
) );
my
(
$file
,
$io
);
my
$args
=
$args
[ 0 ];
my
$sig
=
$args
->{sig} ||
'TERM'
;
my
$pids
=
$args
->{pids} || [];
$args
->{pid} and
push
@{
$pids
},
$args
->{pid};
if
(
$file
=
$args
->{file} and
$io
= io(
$file
) and
$io
->is_file) {
push
@{
$pids
},
$io
->
chomp
->
lock
->getlines;
$sig
eq
'TERM'
and
unlink
$file
;
}
(
defined
$pids
->[0] and
$pids
->[0] =~ m{ \d+ }mx) or throw
'Process id bad'
;
for
my
$mpid
(@{
$pids
}) {
if
(
exists
$args
->{flag} and
$args
->{flag} =~ m{ one }imx) {
CORE::
kill
$sig
,
$mpid
;
next
;
}
my
@pids
=
reverse
$self
->child_list(
$mpid
);
CORE::
kill
$sig
,
$_
for
(
@pids
);
$args
->{force} or
next
;
sleep
3;
@pids
=
reverse
$self
->child_list(
$mpid
);
CORE::
kill
'KILL'
,
$_
for
(
@pids
);
}
return
OK;
}
sub
signal_process_as_root {
my
(
$self
,
@args
) =
@_
;
return
$self
->signal_process( arg_list
@args
);
}
1;