#!/usr/local/bin/perl -w

use strict;

my $Parse_Opt =
  { %{ default_opt() }
  , 'minimum'  => 3
  , 'file'  => q[/home/parv/cf/fvwm/fvwm-make-key-menu.cf]
  , 'new-section'  => qr/^ \@\@ \s+ (\S+ .*) /x
  , 'parent-menu' => q/window-op-test/
  , 'code' =>
      sub { $_[0] =~ s/^\s+//;
            $_[0] =~ s/\s+$//;
            $_[0] =~ s/\s{2,}/ /g;
            $_[0];
          }
  } ;

sanity_check( $Parse_Opt );

my ($menu_items , $key_bindings) = parse_config( $Parse_Opt );

die "Nothing to print\n"
  unless keys %{$menu_items} and keys %{$key_bindings};

printf "%s" , $_
  foreach
    ( @{ make_menu($Parse_Opt->{'parent-menu'} , $menu_items , $key_bindings) }
    , @{ make_binding($key_bindings) }
    ) ;

exit;

sub sort_lc
{ return
    [ sort { lc $a cmp lc $b } @{ $_[0] } ];
}


sub default_opt
{ #  default option
  return
    { 'minimum'  => 2
    , 'separator' => qr/ \s* :: \s* /x
    , 'comment'  => qr/^ \s* \# /x
    , 'skip'  => qr/^ \s* (?: \# | $ ) /x
    , 'code' => sub { }
    } ;
}

sub parse_config
{ my $opt = shift;
  my ($menu_name , %menu_items , %bindings);

  open CF , '<' , $opt->{'file'}
    or die "cannot open $opt->{'file'}: $!\n";

  while (defined (my $line = <CF>) )
  { chomp $line;

    next if $line =~ m/$opt->{'skip'}/;

    $opt->{'code'}->($line);

    #  get menu name
    $line =~ m/$opt->{'new-section'}/
      && do { $menu_name = $1; next; };

    die "No menu name defined, but supposedly related enteries are!\n"
      unless defined $menu_name;

    my @fields =
      split /$opt->{'separator'}/ , $line;

   warn "Not enough required fields in: $line\n" , next
     if $opt->{'minimum'} > scalar @fields;

    my ($func , $item) = (shift @fields , shift @fields);

    push @{ $bindings{$func} } , $_ foreach @fields;

    push @{ $menu_items{$func} }
      , $menu_name , ($item ? $item : $func) ;
  }

  close CF
    or die "cannot close $opt->{'file'}: $!\n";

  return (\%menu_items , \%bindings);
}

sub make_binding
{ my $bindings = shift;
  my @output;

  foreach my $func (keys %{$bindings} )
  { foreach my $kb ( @{ $bindings->{$func} } )
    { push @output
        , sprintf( qq{key %9s %6s %5s  %s \n}
                  , (split /\s+/ , $kb)[0..2]
                  , $func
                  ) ;
    }
  }

  return sort_lc( \@output );
}

sub make_menu
{ my ($parent_menu , $menu_items , $bindings) = @_;
  return
    [ @{ sort_lc( &menu_popup ) }
    , @{ sort_lc( &menu_enteries ) }
    ];
}

#  create pop up menu enteries for parent menu
sub menu_popup
{ my ($parent_menu , $menu_items) = @_[0,1];

  my %popups =
    map { $menu_items->{$_}->[0] => undef; }
      keys %{$menu_items} ;

  return
    [ map { my $short = $_;
            $short =~ s/^ [^-]+ - (.+) /$1/x;
            sprintf qq{AddToMenu  "$parent_menu" "&%s"  Popup "%s"\n}
              , $short , $_ ;
          }
        keys %popups
    ] ;
}

sub menu_enteries
{ my ($menu_items , $bindings) = @_[1,2];
  my @output;

  #  create function enteries for individual menus
  foreach my $func (keys %{$menu_items} )
  { #  save only the first binding
    $bindings->{$func}->[0] =~ s/\s{2,}/ /g;

    push @output
      , sprintf qq{AddToMenu  "%s"  "%s (%s)"  %s\n}
          , @{ $menu_items->{$func} }[0,1]
          , $bindings->{$func}->[0]
          , $func ;
  }

  return \@output;
}

sub sanity_check
{ my $opt = shift;

  my ($errs , %message) = (0);

  unless ( $opt->{'minimum'} )
  { $message{ ++$errs } =
      qq{ Minimum number of expected fields given is incorrect.
        };
  }

  unless ( ref $opt->{'code'} eq 'CODE' )
  { $message{ ++$errs } =
      qq{ Code option is given but is really not.
        };
  }

  foreach my $re qw/new-section separator comment skip/
  { next if ref $opt->{$re};
    $message{ ++$errs } =
      qq{ Given option, $re, is not regex.
        };
  }

  if ($errs)
  { $_ =~ s/\s+$// , warn $message{$_} , "\n"
      foreach sort { $a <=> $b } keys %message;
    exit 1;
  }

  return 1;
}