#!/usr/bin/perl -w
################################################################################
#
#  regenerate -- regenerate baseline and todo files
#
################################################################################
#
#  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
#  Version 2.x, Copyright (C) 2001, Paul Marquess.
#  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
#
#  This program is free software; you can redistribute it and/or
#  modify it under the same terms as Perl itself.
#
################################################################################

use strict;
use File::Path;
use File::Copy;
use Getopt::Long;
use Pod::Usage;

require './devel/devtools.pl';
require './parts/ppptools.pl';

our %opt = (
  check   => 1,
  debug   => 0,
  verbose => 0,
  yes     => 0,
);

GetOptions(\%opt, qw( check! verbose yes install=s blead=s blead-version=s
                      debug=i debug-start=s skip-devels)) or die pod2usage();

identify();

unless (-e 'parts/embed.fnc' and -e 'parts/apidoc.fnc') {
  print "\nOooops, $0 must be run from the Devel::PPPort root directory.\n";
  quit_now();
}

if (! $opt{'yes'}) {
    ask_or_quit("Are you SURE you have:\n1) updated parts/embed.fnc to"
              . "latest blead?\n2) run devel/mkapidoc.pl to update"
              . " parts/apidoc.fnc?\n3) run devel/mkppport_fnc.pl to"
              . "update parts/ppport.fnc?\n");
}

my $files_glob_pattern = '[12345789]*';
my %files = map { ($_ => [glob "parts/$_/$files_glob_pattern"]) } qw( base todo );

my(@notwr, @wr);
for my $f (map @$_, values %files) {
  push @{-w $f ? \@wr : \@notwr}, $f;
}

if (@notwr) {
  if (@wr) {
    print "\nThe following files are not writable:\n\n";
    print "    $_\n" for @notwr;
    print "\nAre you sure you have checked out these files?\n";
  }
  else {
    print "\nAll baseline / todo file are not writable.\n";
    ask_or_quit("Do you want to try to check out these files?");
    unless (runtool("wco", "-l", "-t", "locked by $0", @notwr)) {
      print "\nSomething went wrong while checking out the files.\n";
      quit_now();
    }
  }
}

# Check that there is only one entry in the whole system for each item
my @embeds = parse_embed(qw(parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc));
my %seen;
for my $entry (@embeds) {
    my $Mflag = defined $entry->{flags}{M};
    $seen{"$entry->{name}/$entry->{cond}/$Mflag"}++;
}
my %bads = grep { $seen{$_} > 1 } keys %seen;
if (keys %bads) {
    print "The following items have multiple entries in the parts/*.fnc files.\n",
          " Regenerate apidoc.fnc, then ppport.fnc and try again.  If this\n",
          " doesn't work, choose the best version for each symbol and delete\n",
          " the others: ",
        join "\n", keys %bads, "\n";
    quit_now();
}

if (-e 'ppport.h') {
    my $blead = $opt{blead};
    $blead = get_and_sort_perls(\%opt)->[0]->{path} unless $blead;

    # Get list of things we provide
    my %provided = map { /^(\w+)/ ? ( $1 => 1 ) : () }
                                            `$blead ppport.h --list-provided`;

    # Get the list of macros that are hard to test.
    my @unorthodox = map { exists $_->{flags}{u} ? $_->{name} : () } @embeds;

    # Keep on that list only the things we provide
    @unorthodox = grep { exists $provided{$_} } @unorthodox;

    # And get the list of known hard things.
    my $hard_ref = &known_but_hard_to_test_for;

    # If we provide something, it better be on the known things list
    my @bad = grep { ! exists $hard_ref->{$_} } @unorthodox;
    undef @bad;
    if (@bad) {
        print "The following items need to be manually added to the list in",
            " parts/ppptools.pl: known_but_hard_to_test_for(): ",
            join ", ", @bad, "\n";
        quit_now();
    }
}

# If starting in the middle, don't zap what we've already done
if (! $opt{'debug-start'}) {
    for my $dir (qw( base todo )) {
        my $cur_file_count = @{$files{$dir}};
        next unless $cur_file_count > 0;  # Don't remove if nothing to back up
        my $cur = "parts/$dir";
        my $old = "$cur-old";
        if (-e $old) {
            my @temp = glob "parts/$dir/$files_glob_pattern";
            my $saved_file_count = @temp;
            next unless $saved_file_count > 0;  # Don't remove if nothing in it

            # Ask to remove the saved ones.  If there are already many saved
            # files, ask even if the parameter says the answer is always yes.
            # (The criteria here for "many" could be profitably revised)
            if ($saved_file_count > $cur_file_count || ! $opt{'yes'}) {
                my $message = "";;
                $message .= "There are $saved_file_count already saved files,"
                          . " and $cur_file_count new ones\n"
                                                        if $cur_file_count > 0;
                $message .= "Do you want me to remove the old $old directory?";
                ask_or_quit($message);
            }
            rmtree($old);
        }
        mkdir $old;
        print "\nBacking up $cur in $old.\n";
        for my $src (@{$files{$dir}}) {
            my $dst = $src;
            $dst =~ s/\Q$cur/$old/ or die "Ooops!";
            move($src, $dst) or die "Moving $src to $dst failed: $!\n";
        }
    }
}

my @perlargs;
push @perlargs, "--debug=$opt{debug}" if $opt{debug};
push @perlargs, "--install=$opt{install}" if $opt{install};
push @perlargs, "--blead=$opt{blead}" if $opt{blead};
push @perlargs, "--debug-start=$opt{'debug-start'}" if $opt{'debug-start'};
push @perlargs, "--skip-devels" if $opt{'skip-devels'};

my $T0 = time;
my @args = ddverbose();
push @args, '--nocheck' unless $opt{check};
push @args, "--blead-version=$opt{'blead-version'}" if $opt{'blead-version'};
push @args, @perlargs;

# Look for all the NEED_foo macros
my @NEED;
for my $file (all_files_in_dir('parts/inc')) {
  my $spec = parse_partspec($file);
  next unless $spec->{'xsinit'};
  while ($spec->{'xsinit'} =~ / ^ ( \# \s* define \s+  NEED_ \w+ ) \s /xmg) {
    push @NEED, "$1";
  }
}

# Make the list available to parts/apicheck.pl
$ENV{'DPPP_NEED'} = join "\n", sort @NEED;

# Find out what symbols were in what releases
print "\nBuilding baseline files...\n\n";

unless (runperl('devel/mktodo', '--base', @args)) {
  print "\nSomething went wrong while building the baseline files.\n";
  quit_now();
}

# Then find out what ppport.h buys us by repeating the process above, but
# using ppport.h
print "\nBuilding todo files...\n\n";

unless (runperl('devel/mktodo', @args)) {
  print "\nSomething went wrong while building the todo files.\n";
  quit_now();
}

print "\nAdding remaining info...\n\n";

unless (runperl('Makefile.PL') and
        runtool('make') and
        runperl('devel/scanprov', '--mode=write', @perlargs)) {
  print "\nSomething went wrong while adding the baseline info.\n";
  quit_now();
}

my($wall, $usr, $sys, $cusr, $csys) = (time - $T0, times);
my $cpu = sprintf "%.2f", $usr + $sys + $cusr + $csys;
$usr = sprintf "%.2f", $usr + $cusr;
$sys = sprintf "%.2f", $sys + $csys;

print <<END;

API info regenerated successfully.

Finished in $wall wallclock secs ($usr usr + $sys sys = $cpu CPU)

Don't forget to check in the files in parts/base and parts/todo.

END

__END__

=head1 NAME

regenerate - Automatically regenerate Devel::PPPort's API information

=head1 SYNOPSIS

  regenerate [options]

  --nocheck      don't recheck symbols that caused an error
  --verbose      show verbose output
  --yes          the answer to all the standard questions is 'yes',
                 can be used to nohup this.
  --skip-devels  do not look at development-only releases

=head1 COPYRIGHT

Copyright (c) 2006-2013, Marcus Holland-Moritz.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

See L<Devel::PPPort> and L<HACKERS>.

=cut