From 748542533bf8cf422fa0ee81812c4018ae58c2e1 Mon Sep 17 00:00:00 2001
From: Stephan Barth <stephan.barth@uniwork.de>
Date: Sun, 20 Oct 2024 16:38:46 +0200
Subject: [PATCH] build(utils/develop-status.pl): Added status script for
 display of development state.

---
 utils/develop-status.pl | 147 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 147 insertions(+)
 create mode 100755 utils/develop-status.pl

diff --git a/utils/develop-status.pl b/utils/develop-status.pl
new file mode 100755
index 000000000..b8b385c72
--- /dev/null
+++ b/utils/develop-status.pl
@@ -0,0 +1,147 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+my $develop = 'develop';
+my $runner = 'podman';
+
+if($ENV{PWD}=~m#/utils$#) {
+  chdir("..");
+}
+
+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;
+#}
+
+
+
+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"],
+  ]);
+
+for my $devStamp(@devs) {
+  print "+ Development $devStamp found\n";
+  devdirInfo($devStamp, "$develop/$devStamp")
+}
+#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")
+#}
+
+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};
+  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
+}
+
+
+