#!/usr/bin/perl -W

# Pragmas -----------------------------

use strict;

use Fatal                 qw( open close );
use File::Basename        qw( basename );
use File::Spec::Functions qw( catdir catfile );
use FindBin               qw( $Bin );

use lib qw( lib );
use Class::MethodMaker::OptExt qw( OPTEXT );

# Constants ---------------------------

use constant COMP_DIR  => catdir $Bin, 'components';

# Utility -----------------------------

# Main -----------------------------------------------------------------------

sub min {
  my $Result;

  for (@_) {
    $Result = $_
      if ! defined $Result or $Result > $_;
  }

  return $Result;
}

sub read_file {
  my ($fn) = @_;
  open my $fh, '<', $fn;
  local $/ = undef;
  my $text = <$fh>;
  close $fh;
  return $text;
}

# Parse in methods file ---------------

my %methods;
{
  for my $fn (@ARGV) {
    open my $methods, '<', $fn;
    local $/ = "\n";
    my $methname;
    my ($doc, $text) = ('') x 2;
    my ($pod, $code) = (0)  x 2;
    while (<$methods>) {
      chomp;
      if ( $pod ) {
        $doc .= "$_\n";
        $pod = 0
          if /^=cut\b/;
      } elsif ( /^=(?:pod|head\d?)\b/ ) {
        $pod = 1;
        $doc .= "$_\n";
      } elsif ( $code ) {
        if ( /^}\s*$/ ) {
          $code = 0;
        } else {
          $text .= "$_\n";
        }
      } elsif ( /^\s*sub\s+([a-z_]+)\s+\{(.*)$/ms ) {
        my $protometh = $1;
        my $prototext = $2;

        if ( defined $methname ) {
          $methods{$methname}->{text} = $text;
          $methods{$methname}->{doc}  = $doc;
          $text = $doc = '';
        }

        $methname = $protometh;
        if ( length($prototext) and $prototext !~ /^\s*$/ ) {
          $text = "$prototext\n";
        } else {
          $text = '';
        }
        $code = 1;
      }
    }

    if ( defined $methname ) {
      $methods{$methname}->{text} = $text;
      $methods{$methname}->{doc}  = $doc;
      $text = $doc = '';
    }
  }
}

my @storage_names = Class::MethodMaker::OptExt->option_names;

# Write out methods -------------------

my %import;

while ( my ($meth, $value) = each %methods ) {
  print "package Class::MethodMaker::", basename($ARGV[0], '.m'), ";\n";

  print <<'END';
use strict;
use warnings;

use AutoLoader 5.57  qw( AUTOLOAD );
our @ISA = qw( AutoLoader );

use Carp qw( carp croak cluck );

use constant DEBUG => $ENV{_CMM_DEBUG} ? 1 : 0;

__END__
END

  # Print doc
  if ( exists $value->{doc} ) {
    my $doc = $value->{doc};
    $doc =~ s/^=cut\n=pod\n//mg;
    print "\n", $doc, "\n";
  }

  # Print each storage type
  for my $idx (0..2**@storage_names-1) {
    my @st = map $storage_names[$_], grep $idx & 2**$_, 0..$#storage_names;
    my ($suffix, undef) = Class::MethodMaker::OptExt->encode($meth, \@st);
    next
      if ! defined $suffix;

    my $name = substr($meth, 0, 4) . $suffix;
    my $code = $value->{text};
    my %replace = Class::MethodMaker::OptExt->replace(\@st);

    # Do Imports ----------------------

    $code =~ s/^(.*)%%IMPORT\((.*)\)%%/
               my ($i, $fn) = ($1, $2);
               my $t;
               if ( exists $import{$fn} ) {
                 $t = $import{$fn};
               } else {
                 $t = $import{$fn} =
                   read_file(catfile COMP_DIR, "${fn}.pm");
               }

               $t =~ s!^!$i!mg
                 if $i =~ m!^\s+$!;
               $t/meg;

    # Handle V1/V2 differences --------
    my $v1_compat = grep $_ eq 'v1_compat', @st;
    my $default = grep /default/, @st;
    # This needs to be done first because defchk (potentially) refers to
    # storage
    # Duplicate changes at YYY below
    # XXX
    $code =~ s/%%V1COMPAT_ON%%(.*?)%%V1COMPAT_OFF%%/$v1_compat ? $1 : ''/mseg;
    $code =~ s/%%V2ONLY_ON%%(.*?)%%V2ONLY_OFF%%/$v1_compat ? '' : $1/mseg;
    $code =~ s/%%DEFAULT_ON%%(.*?)%%DEFAULT_OFF%%/$default ? $1 : ''/mseg;
    $code =~ s/^(.*?)\s*%%V1COMPAT%%\s*$/$v1_compat ? $1 : ''/meg;
    $code =~ s/^(.*?)\s*%%V2ONLY%%\s*$/$v1_compat ? '' : $1/meg;
    $code =~ s/^(.*?)\s*%%DEFAULTONLY%%\s*$/$default ? $1 : ''/meg;

    # Handle callback invocations -----

    $code =~ s/^(.*)%%READ(\d)\((\S+)\)%%/
               my ($i, $n, $v) = ($1, $2, $3);
               (my $t = $replace{read}->[$n]) =~
                 s!(?<=.)^!' ' x length($i)!mseg;
               $t =~ s!__VALUE__!$v!g;
               "$i$t";
              /meg;

    $code =~ s/^(.*)%%DEFCHECK([@%\$])(.*)%%/
               my ($i, $s, $j) = ($1, $2, $3);
               (my $t = $replace{predefchk} . $replace{defchk}) =~ s!(?<=.)^!' ' x length($i)!mseg;
               $t =~ s!%%STORAGE%%!$j!g
                 if length $j;
               $t =~ s!__SIGIL__!$s!g;
               "$i$t"/meg;

    my $store = grep $_ eq 'store_cb', @st;
    $code =~ s/%%IFSTORE\((.*?),(.*?)\)%%/$store ? $1 : $2/meg;

    # ASGNCHK needs to come before STORAGE because it might well refer to
    # STORAGE
    $code =~ s/^(.*)%%ASGNCHK([@%\$])\((.*?)\)%%/
               my ($i, $s, $f) = ($1, $2, $3);
               (my $t = $replace{asgnchk} . $replace{postac}) =~
                 s!(?<=.)^!' ' x length($i)!mseg;
               $t =~ s!__FOO__!$f!g;
               $t =~ s'__ATTR__'$name'g;
               $t =~ s!__SIGIL__!$s!g;
               "$i$t"/meg;

    $code =~ s/^(.*)%%STORE\((.*?),\s*(.*?)(?:,\s*(.*?))?\)%%/
               my ($i, $m, $n, $o) = ($1, $2, $3, $4);
               my $p = substr($n,0,1) eq '$' ? $n : "$n";
               $o = '' if ! defined $o;
               (my $t = $replace{store}) =~ s!(?<=.)^!' ' x length($i)!mseg;
               $t =~ s!__NAME__!$n!g;
               $t =~ s!__NAMEREF__!$p!g;
               $t =~ s!__VALUE__!$m!g;
               $t =~ s!__ALL__!$o!g;
               "$i$t"/meg;

    # READINIT used for performing, e.g., ties even when no assignment has
    # occurred (because looking up a value into play is enough to justify the
    # tie, since the tie may provide a value (e.g., a persistent disk cache)
    $code =~ s/^(.*)%%READINIT([@%\$])%%/
               my ($i, $s) = ($1, $2);
               (my $t = $replace{postac}) =~
                 s!(?<=.)^!' ' x length($i)!mseg;
               $t =~ s'__ATTR__'$name'g;
               $t =~ s'__TYPE__'$type'g;
               $t =~ s!__SIGIL__!$s!g;
               "$i$t"/meg;
    # REFER needs to come before STORAGE because it might well refer to
    # STORAGE
    $code =~ s/^(.*)%%RESET([@%\$]?)(?:\((.*?)\))?%%/
               my ($i, $s, $f) = ($1, $2, $3);
               die "Parameterized RESET not yet handled!\n"
                 if defined $f and length $f;
               die "RESET takes a terminating sigil\n"
                 unless length $s;
               (my $t = $replace{reset}) =~
                 s!(?<=.)^!' ' x length($i)!mseg;
               $t =~ s!__SIGIL__!$s!g;
               "$i$t"/meg;
    $code =~ s/%%STORAGE(?:\((.*)\))?%%/
               my $f = $1;
               my $t = $replace{refer};
               $t = "$f\{$t\}"
                 # Special case for $ because scalars are stored direct as
                 # scalars rather than as references to scalars (whereas
                 # arrays, for example, are stored as references to arrays).
                 # Although this arrangement is less seamless than using
                 if defined $f and length $f and $f ne '$';
               $t;
              /eg;
    $code =~ s/%%STORDECL%%/$replace{decl}/g;

    # And again, because some replaced code uses this too!
    # Duplicate changes at XXX above
    # YYY
    $code =~ s/%%V1COMPAT_ON%%(.*?)%%V1COMPAT_OFF%%/$v1_compat ? $1 : ''/mseg;
    $code =~ s/%%V2ONLY_ON%%(.*?)%%V2ONLY_OFF%%/$v1_compat ? '' : $1/mseg;
    $code =~ s/^(.*?)\s*%%V2ONLY%%\s*$/$v1_compat ? '' : $1/meg;
    $code =~ s/^(.*?)\s*%%V1COMPAT%%\s*$/$v1_compat ? $1 : ''/meg;

    $code =~ s/(%%\S+)/warn "%% sequence unreplaced: $1\n";$1/eg;

    # Untabify
    1 while $code =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
    # Trim trailing whitespace
    $code =~ s/ +$//mg;
    # Tidy identation
    my $strip = min map length, $code =~ /^ +/mg;
    $code =~ s/^ {$strip}//mg;
    $code =~ s/\A\s*(.*?)\s*\Z/$1/ms;
    $code =~ s!^(.*)$!
      $_ = $1;
      my $pod = /^=pod/../^=cut/;
      $pod ? $_ : "  $_";
    !emg;
    print  "\n", '#', '-' x 18, "\n";
    print '# ', $meth, ' ', join(' - ', @st), "\n";
    print "\nsub $name {\n$code\n}\n";
  }

  print  "\n", '#', '-' x 36, "\n";
  print "\n";
}

# Add trailing doc --------------------

print "1; # keep require happy\n";



__END__