#!/usr/bin/perl

# Copyright (C) 2007 Eric L. Wilhelm

use warnings;
use strict;

=head1 NAME

xs_proto_map - turn Wx prototypes into perl data

=cut

package bin::xs_proto_map;

sub main {
  my (@args) = @_;

  my $in_dir = shift(@args);

  my %bits = acquire_protos($in_dir);
  #warn join("\n  ", 'found:', map({"$_ => $bits{$_}"} keys %bits));

  # normalize this oddball
  $bits{'RadioBox'} =~ s/\bpoint\b/pos/ or die;

  #use YAML; warn YAML::Dump(\%bits);

  # not much point in these two
  #delete($bits{'Wizard'});
  delete($bits{'WizardPage'});

  foreach my $v (values(%bits)) {
    $v =~ s/\bpos\b/position/; # rename to not look like CORE::pos

    $v = [split(/ *, */, $v)];
    my $p = shift(@$v);
    $p eq 'parent' or die "trouble in @$v"; # ASSERT
    my $id = shift(@$v); # don't need that either
    $id =~ m/^id\b/ or die $id; # ASSERT
    #$v->[0] = 'id = -1';

  }

  my %del = map({$_ => 1} qw(title));
  # now break them into defaults
  my %defaults;
  foreach my $key (keys(%bits)) {
    my $def = $defaults{$key} = {};
    foreach my $item (@{$bits{$key}}) {
      my ($k, $v) = split(/ *= */, $item);
      if(defined($v) and not $del{$k}) {
        $v =~ s/wxEmptyString//g;
        $v =~ s/\([^\)]+\*\)//; # strip castings
        $v =~ s/^wxT\("(.*)"\)/$1/; # name always gets dropped?
        $def->{$k} = $v;
      }
      $item = $k;
    }
  }
  #use YAML; warn YAML::Dump(\%bits, \%defaults);

  foreach my $v (values(%defaults)) {
    if(exists($v->{choices})) {
      $v->{choices} = '[]';
    }
    foreach my $k (qw(position size validator bitmap)) {
      exists($v->{$k}) or next;
      $v->{$k} =~ s/^\&?wx(.*)/Wx::wx$1()/;
    }
    if(exists($v->{style})) {
      $v->{style} =~ s/wx(\w+)\b/Wx::wx$1()/g;
    }
  }

  # fixups?
  {
    my $pod = make_pod(\%bits, \%defaults);
    # TODO prepend/append the rest of that podpage
    my $podfile = 'lib/wxPerl/Constructors/doc.pod';
    open(my $fh, '>', $podfile) or die "cannot write '$podfile' $!";
    # and print it
    print $fh $pod;
  }

  # assumes name is always last
  delete($_->{name}) for(values %defaults);

  require Data::Dumper;
  local $Data::Dumper::Quotekeys = $Data::Dumper::Quotekeys = 0;
  local $Data::Dumper::Indent = $Data::Dumper::Indent = 0;
  my $arg_dump = Data::Dumper::Dumper(\%bits);
  $arg_dump =~ s/^\$VAR1/our \$ARGPOS/ or die;
  $arg_dump =~ s/\],/],\n  /g;
  my $def_dump = Data::Dumper::Dumper(\%defaults);
  $def_dump =~ s/^\$VAR1/our \$DEFAULTS/ or die;
  $def_dump =~ s/=> *'([^']+)'/=> $1/g;
  $def_dump =~ s/\},/},\n  /g;

  my $pm_file = 'lib/wxPerl/Constructors/argmap.pm';
  open(my $fh, '>', $pm_file) or die "cannot write '$pm_file' $!";
  print $fh "package wxPerl::Constructors::argmap;\n";
  print $fh join("\n",
    '# XXX autogenerated, no user-servicable parts',
    '# XXX depends on Wx.pm',
    '# XXX do not use() directly',
    '# XXX are you still here?  STOP!',
    ), "\n";
  print $fh "\nuse warnings;\nuse strict;\n\n";
  print $fh ('#')x72, "\n";
  print $fh $arg_dump, "\n", $def_dump, "\n";

  print $fh join("\n",
    map({"sub $_ {\$$_};"} qw(ARGPOS DEFAULTS))
  ), "\n";

  print $fh '# v'.'im:nowrap', "\n";
  print $fh "1;\n";

  close($fh) or die "write error '$pm_file' $!";

}

=head2 acquire_protos

  my %bits = acquire_protos($in_dir);

=cut

sub acquire_protos {
  my ($in_dir) = @_;

  my @files = glob("$in_dir/*");
  @files or die "no files";

  my %protos;
  foreach my $file (@files) {
    warn "$file\n";
    my $current_package;
    open(my $fh, '<', $file) or die "oops $file";
    while(my $line = <$fh>) {
      chomp($line);
      if($line =~ m/\bPACKAGE=Wx::([\w:]*)/) {
        $current_package = $1;
      }
      elsif($line =~ m/^newFull\( *CLASS, (.*)\)$/) {
        my $proto = $1;
        $proto =~ s/ +$//;
        $current_package or die "arg $file";
        $protos{$current_package} = $proto;
      }
      elsif($current_package and
        ($line =~ m/^wx${current_package}::new\( (parent, id,.*)\)$/)) {
        my $proto = $1;
        $proto =~ s/ +$//;
        $protos{$current_package} = $proto;
      }

    }
  }
  return(%protos);
} # end subroutine acquire_protos definition
########################################################################

=head2 make_pod

  my $pod = make_pod(\%bits, \%defaults);

=cut

my $URL_BASE = 'http://wxwidgets.org/manuals/stable/wx_';
sub make_pod {
  my ($b, $d) = @_;

  my @pod;
  push(@pod, '='.'head1 NAME','',
    'wxPerl::Constructors::doc - constructor calling syntax','',
    '='.'head1 METHODS','',
    'NOTE:  This documentation is autogenerated.',
    '',
    'See L<wxPerl::Constructors> for other info.','',
  );
  foreach my $key (sort(keys(%$b))) {
    my $cb = $b->{$key};
    my $cd = $d->{$key};

    my $class = 'wxPerl::' . $key;

    my $thingy = 'wx' . lc($key);
    my $url = $URL_BASE . $thingy . '.html'; #' . $thingy . 'ctor';

    my @args;
    my @opts = ([id => -1]);
    foreach my $k (@$cb) {
      if(exists($cd->{$k})) {
        my $val = $cd->{$k};
        $val = "''" unless(length($val));
        push(@opts, [$k, $val]);
      }
      else {
        push(@args, '$' . $k);
      }
    }
    my $longest = 0;
    my @len;
    for(@opts) {
      my $l = length($_->[0]);
      $longest = $l if($l > $longest);
    }
    for(@opts) {
      $_ = sprintf("%-${longest}s => %s,", @$_);
    }

    my $entry = '  ' . $class . '->new(' . "\n" .
      '    ' . join("\n    ",
        '$parent,', map({"$_,"} @args), @opts
      ) . "\n  );";
    push(@pod, '='.'head2 ' . $class, '');
    push(@pod, $entry, '');
    push(@pod, $url, '');
  }
  return(join("\n", @pod));
} # end subroutine make_pod definition
########################################################################

package main;

if($0 eq __FILE__) {
  bin::xs_proto_map::main(@ARGV);
}

# vi:ts=2:sw=2:et:sta
my $package = 'bin::xs_proto_map';