source: branches/tree/SOURCE_TOOLS/sortfig.pl

#!/usr/bin/perl

use strict;
use warnings;

my $reg_key = qr/^([0-9\.-]+\s+){13}(.*)$/o;
my $reg_isLabel = qr/^(\$)?(to:)?([XY]+:)?/o;

sub defEmpty($) {
  my ($whatever) = @_;
  defined $whatever ? $whatever : "";
}
sub ifdef($) {
  my ($whatever) = @_;
  defined $whatever ? 1 : 0;
}

my $ASCII1 = chr(1);

sub lessKey($$) {
  my ($a,$b) = @_;

  my ($ato,$aIsLab,$aXY,$arest) = ('',0,'',$a);
  my ($bto,$bIsLab,$bXY,$brest) = ('',0,'',$b);
  if ($a =~ $reg_isLabel) { ($ato,$aIsLab,$aXY,$arest) = (defEmpty($2),ifdef($1),$3,$'); }
  if ($b =~ $reg_isLabel) { ($bto,$bIsLab,$bXY,$brest) = (defEmpty($2),ifdef($1),$3,$'); }

  $arest =~ s/($ASCII1|\\001)x*$//;
  $brest =~ s/($ASCII1|\\001)x*$//;

  my ($atxt,$btxt) = (lc($arest),lc($brest));
  $atxt =~ s/[^a-z0-9]//go;
  $btxt =~ s/[^a-z0-9]//go;

  my $cmp = 0;
  if ($aIsLab != $bIsLab) {
    my $prefixLen = 3; # reduce to make stable
    my ($apre,$bpre) = (substr($atxt,0,$prefixLen),substr($btxt,0,$prefixLen));
    if ($apre eq $bpre) {
      $cmp = $aIsLab <=> $bIsLab;
    }
    else {
      $cmp = $apre cmp $bpre;
    }
  }
  else {
    $cmp = $atxt cmp $btxt;
    if ($cmp==0) {
      $cmp = $ato cmp $bto;
      if ($cmp==0) {
        $cmp = length($a) <=> length($b);
        if ($cmp==0) {
          $cmp = $a cmp $b;
        }
      }
    }
  }
  if ($cmp==0) { die "no order defined ($a,$b)"; }
  $cmp;
}

my $formatDetected = undef;

sub sort4(\@) {
  my ($lines_r) = @_;

  my %keyedLines = ();

  foreach my $line (@$lines_r) {
    if ($line =~ $reg_key) {
      my $key = $2;
      while (exists $keyedLines{$key}) { $key .= 'x'; } # avoid overwriting keys
      $keyedLines{$key} = $line;
      if (not defined $formatDetected) {
        if ($key =~ /$ASCII1/) { $formatDetected = 'old'; }
        if ($key =~ /\\001/o) { $formatDetected = 'new'; }
      }
    }
    else {
      die "unexpected line '$line'";
    }
  }

  my @sortedKeys = sort { lessKey($a,$b); } keys %keyedLines;
  my @sortedLines = map { $keyedLines{$_}; } @sortedKeys;

  my $countIn  = scalar(@$lines_r);
  my $countOut = scalar(@sortedLines);
  if ($countOut != $countIn) {
    die "size changed in sort4 ($countIn -> $countOut)\n";
  }

  my $differs = 0;
  for (my $i=0; $i<$countIn and $differs==0; ++$i) {
    if ($sortedLines[$i] ne $$lines_r[$i]) {
      $differs = 1;
    }
  }

  if ($differs) {
    @$lines_r = @sortedLines;
  }
  return $differs;
}

sub warnUnwantedItems($$$$) {
  my ($fig,$item_line,$item_count,$description) = @_;
  if ($item_count>0) {
    print "$fig:$item_line: Warning: seen $item_count $description".($item_count>1 ? 's' : '')."\n";
  }
}

sub sortFig($) {
  my ($fig) = @_;

  $formatDetected = undef;

  eval {
    my $changes = 0;
    my $HEADERSIZE = 10;

    my @out = ();
    my @in4 = ();

    my @item_count = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
    my @item_line  = @item_count;

    open(FIG,'<'.$fig) || die "cannot read '$fig' (Reason: $!)";
    my $line;
    my $linenr = 0;
    while (defined($line=<FIG>)) {
      ++$linenr;
      my $num = -1;
      if ($linenr>=$HEADERSIZE) {
        if ($line =~ /^([0-9])\s/o) {
          $num = $1;
        }
        elsif ($line =~ /^-([0-9])/o) {
          $num = $1 + 10;
        }

        # log which item types are used in xfig:
        ++$item_count[$num];
        $item_line[$num] = $linenr;

        if ($num == 4) {
          push @in4, $line;
        }
        else {
          if (scalar(@in4)) { $changes += sort4(@in4); push @out,@in4; @in4=(); }
          push @out, $line;
        }
      }
      else {
        if ($line =~ /^#FIG\s2/o) { $HEADERSIZE = 2; } # older format -> shorter header
        push @out, $line;
      }
    }
    if (scalar(@in4)) { $changes += sort4(@in4); push @out,@in4; @in4=(); }
    close(FIG);

    warnUnwantedItems($fig,$item_line[0],$item_count[0],"useless color definition");
    warnUnwantedItems($fig,$item_line[1],$item_count[1],"ignored ellipse");
    warnUnwantedItems($fig,$item_line[3],$item_count[3],"ignored spline");
    warnUnwantedItems($fig,$item_line[5],$item_count[5],"ignored arc");
    warnUnwantedItems($fig,$item_line[6],$item_count[6],"(probably) forgotten compound");

    if ($formatDetected eq 'old') {
      print "$fig:0: Warning: ancient fig format detected\n";
    }

    if ($changes>0) {
      print "Sorted changed fig '$fig'\n";
      open(OUT,'>'.$fig) || die "cannot write to '$fig' (Reason: $!)";
      foreach (@out) {
        print OUT $_;
      }
      close(OUT);
    }
  };
  if ($@) {
    die "$@ (while sorting '$fig')";
  }
}

sub getModtime($) {
  my ($fileOrDir) = @_;
  my $modtime = (stat($fileOrDir))[9];
  return $modtime;
}

sub checkFigsNewerThan($$);
sub checkFigsNewerThan($$) {
  my ($figdir,$checkAfter) = @_;

  my @sub = ();

  opendir(DIR, $figdir) || die "cannot read directory '$figdir' (Reason: $!)";
  foreach (readdir(DIR)) {
    if ($_ ne '.' and $_ ne '..') {
      my $full = $figdir.'/'.$_;
      if (-d $full) {
        push @sub, $full;
      }
      elsif (-f $full) {
        if ($_ =~ /\.fig$/) {
          my $mod = getModtime($full);
          if ($mod>$checkAfter) {
            sortFig($full);
          }
        }
      }
    }
  }
  closedir(DIR);

  foreach (@sub) {
    checkFigsNewerThan($_,$checkAfter);
  }
}

sub main() {
  my $topdir = $ENV{ARBHOME};

  my $srctools = $topdir.'/SOURCE_TOOLS';
  my $figbase  = $topdir.'/lib/pictures';

  my $last_check_stamp = $srctools.'/sortfig.stamp';
  unlink($last_check_stamp); # uncomment to force resort of all figs
  # `touch $figbase/ad_branch.fig`;

  if (not -d $srctools) {
    die "No such directory '$srctools'\n ";
  }
  else {
    my $checkAfter = 0;
    if (-f $last_check_stamp) {
      $checkAfter = getModtime($last_check_stamp)-5;
    }

    `touch $last_check_stamp`;
    checkFigsNewerThan($figbase,$checkAfter);
  }
}

# ----------------------------------------

my $args = scalar(@ARGV);
my $done = 0;
if ($args==1) {
  my $arg = shift @ARGV;
  if ($arg eq 'doit') {
    main();
    $done = 1;
  }
}
if (not $done) {
  print "Usage: sortfig.pl doit\n";
  print "Sorts some contents of .fig files, avoiding random useless changes between commits.\n";
}