#!/usr/bin/env perl use strict; use warnings; my $develop = 'develop'; my $runner = 'podman'; if($ENV{PWD}=~m#/utils$#) { chdir(".."); } my %listOutside=( running=>1, _default=>0, # everything for which no key exists ); for my $arg(@ARGV) { if('-a' eq $arg) { %listOutside=(_default=>1); next } if('-h' eq $arg) { usage() } usage("Invalid argument: '$arg'"); } sub usage { my $msg = shift; print "$msg\n\n" if $msg; print "$0 [args] -h display this help text -a show all containers with fitting names even when without containerfile "; exit 1 if $msg; exit 0 } print "== Development status ==\n"; # Find out container status #my @cont = split /\R/, qx($runner ps --no-trunc); #shift @cont; # remove title row # #my %cont = (); #for(@cont) { # m#^([0-9a-f]+)\s# || do { warn "cannot parse output of container runner ($_); status incomplete!"; next }; # $cont{$1} = 1; #} my @cont = split /\R/, qx($runner ps -a --no-trunc -f name='^fradrive.' --format='{{.State}} ::: {{.ID}} ::: {{.Names}}'); my %cont = (); for(@cont) { m#(.*) ::: (.*) ::: (.*)# || next; $cont{$2} = { state=>$1, id=>$2, name=>$3, used=>0, } } if(not -e $develop) { print "No develop directory, seems to be nothing active.\n"; exit } my @devs = filesFromDir($develop, [ qr((?:^\.)), [qr((?:[0-9]{4}-[0-9]{2}-[0-9]{2}T)), 1, "File '%fn' does not look like a development dir, skip"], ]); #my $devDir = undef; #opendir($devDir, "$develop") or die "Cannot open develop directory, because: $!"; #while(my $devStamp = readdir($devDir)) { # next if $devStamp=~m#^\.#; # print "+ Development $devStamp found\n"; # if($devStamp!~m#[0-9]{4}-[0-9]{2}-[0-9]{2}T#) { # warn "$0: Does not look like a development dir, skip" # } # devdirInfo($devStamp, "$develop/$devStamp") #} for my $k(sort { $cont{$a}{state} cmp $cont{$b}{state} || $cont{$a}{name} cmp $cont{$b}{name} } grep { !$cont{$_}{used} } keys %cont) { my $c = $cont{$k}; my $show = $listOutside{$c->{state}} // $listOutside{_default}; print "Fradrive container outside develop file: ($c->{state}) $c->{name} $c->{id}\n" if $show } for my $devStamp(@devs) { print "+ Development $devStamp found\n"; devdirInfo($devStamp, "$develop/$devStamp") } exit 0; sub devdirInfo { my ($name, $path) = @_; my @fns = filesFromDir($path, [qr((?:^\.))]); for my $fn(@fns) { print " + Containerfile $fn found\n"; checkContainerFile("$path/$fn"); } } sub checkContainerFile { my $fn = shift; my $fh = undef; my %h = (); open($fh, '<', $fn) or do { warn "$0: Can not read $fn, because: $!\n"; return }; for(<$fh>) { next if m#^\s*$#; m#(.*)=(.*)# or do { warn "$0: Bad row in containerfile '$fn': $_" }; my ($k, $v) = ($1, $2); if(exists $h{$k}) { warn "$0: In containerfile '$fn': Key '$k' is set multiple times!\n" } $h{$k} = $v; } print " $_=$h{$_}\n" for sort keys %h; my $id = $h{CONTAINER_ID}; $cont{$id}{used} = 1; if(not defined $id) { warn "$0: In containerfile '$fn': No CONTAINER_ID set\n"; return } my $stateLine = qx($runner container inspect -f='{{.State.Status}} ::: {{.Name}}' "$id"); if($stateLine=~m#^(.*?) ::: (.*)$#) { # print " Container is running\n" my ($state, $name) = ($1, $2); print " Containername: $name\n"; if('running' eq $state) { print " Container is running\n"; } else { print " !!! Container is not running but instead in state '$state'\n"; } } else { print " !!! Container is not in the memory anymore !!!\n"; print "STATE: $stateLine\n" } #if($cont{$id}) { # print " Container is running\n" #} else { # print " !!! Container is NOT running\n" #} #$RUNNER ps --no-trunc } #my @find = split /\R/, qx(find $develop); # # #print "FIND\n"; #print " --- $_\n" for @find; #print "CONT\n"; #print " --- $_\n" for @cont; #print "CONT $_\n" for sort keys %cont; sub filesFromDir { my ($path, $exclude) = @_; my $dirh = undef; my @ret = (); my @warn = (); opendir($dirh, $path); DIR: while(my $fn = readdir($dirh)) { for(@$exclude) { my ($re, $negate, $msg) = ($_); ($re, $negate, $msg) = @$_ if 'ARRAY' eq ref $_; if($negate xor $fn=~m#$re#) { if(defined $msg) { $msg=~s#%fn#$fn#; push @warn, [$fn, $msg] } next DIR } } push @ret, $fn } @ret = sort @ret; @warn = sort {$a->[0] cmp $b->[0]} @warn; for(@warn) { warn "$0: $_\n"; } return @ret }