create works again

diff --git a/FORMAT b/FORMAT
index 42f7fa445b41b9a47a06af2644fea0b61b1403a5..276051d5d1a046e54288956ac6f5d0dff0ed618a 100644 (file)
--- a/FORMAT
+++ b/FORMAT
@@ -30,10 +30,10 @@ In-tree, there are metadata files in .topbloke
        deleted         exists (but empty) if patch is deleted
                        exists only in tip branch
 
        deleted         exists (but empty) if patch is deleted
                        exists only in tip branch
 

-       topgit-         name of the topgit branch that this was
-                       imported from and which we should merge from
-                       (plus a newline)
-                       exists only in base branch
+#TBD#  topgit-         name of the topgit branch that this was
+#TBD#                  imported from and which we should merge from
+#TBD#                  (plus a newline)
+#TBD#                  exists only in base branch

 
        [^+]*-          another property that applies to this patch;
                        if not known to this version of topbloke then it
 
        [^+]*-          another property that applies to this patch;
                        if not known to this version of topbloke then it

diff --git a/Topbloke.pm b/Topbloke.pm
index 23024fd6224186c23a13a5fea24eb1dc33817a8b..130aa7b8a631a1a8be2a4cf965376ccd6d9c5c01 100644 (file)
--- a/Topbloke.pm
+++ b/Topbloke.pm
@@ -17,15 +17,17 @@ BEGIN {
 
     $VERSION     = 1.00;
     @ISA         = qw(Exporter);
 
     $VERSION     = 1.00;
     @ISA         = qw(Exporter);

-    @EXPORT      = qw(debug $tiprefs $baserefs
+    @EXPORT      = qw(debug $tiprefs $baserefs %known_metadata

                      run_git run_git_1line run_git_check_nooutput
                      run_git_test_anyoutput git_get_object
                      git_config git_dir chdir_toplevel enable_reflog
                      run_git run_git_1line run_git_check_nooutput
                      run_git_test_anyoutput git_get_object
                      git_config git_dir chdir_toplevel enable_reflog

-                     current_branch parse_patch_spec parse_patch_name
-                     setup_config check_no_unwanted_metadata
+                      check_no_metadata foreach_unknown_metadata
+                      check_clean_tree
+                     setup_config 
+                     current_branch parse_patch_name parse_patch_spec

                      patch_matches_spec
                      foreach_patch
                      patch_matches_spec
                      foreach_patch

-                     propsfile_add_prop depsfile_add_dep
+                     metafile_process depsfile_add_dep

                      wf_start wf wf_abort wf_done wf_contents
                      closeout);
     %EXPORT_TAGS = ( );
                      wf_start wf wf_abort wf_done wf_contents
                      closeout);
     %EXPORT_TAGS = ( );


@@ -34,6 +36,8 @@ BEGIN {
 
 our $git_command = 'git';
 
 
 our $git_command = 'git';
 

+our %known_metadata;
+

 sub debug ($) {
     my ($msg) = @_;
     print STDERR "DEBUG: $msg\n" or die $!;
 sub debug ($) {
     my ($msg) = @_;
     print STDERR "DEBUG: $msg\n" or die $!;


@@ -170,7 +174,7 @@ sub enable_reflog ($) {
     close REFLOG or die $!;
 }    
 
     close REFLOG or die $!;
 }    
 

-sub check_no_unwanted_metadata ($) {
+sub check_no_metadata ($) {

     # for checking foreign branches aren't contaminated
     my ($gitbranch) = @_;
     run_git_check_nooutput('foreign unexpectedly contains',
     # for checking foreign branches aren't contaminated
     my ($gitbranch) = @_;
     run_git_check_nooutput('foreign unexpectedly contains',


@@ -179,6 +183,20 @@ sub check_no_unwanted_metadata ($) {
                           qw(.topbloke));
 }
 
                           qw(.topbloke));
 }
 

+sub foreach_unknown_metadata ($$) {
+    my ($ref, $code) = @_;
+    # Examines $ref.
+    # Executes $code for each tolerable unknown metadata found, with
+    # $_ being the (leaf) name of the metadata file
+    run_git(sub {
+       die unless s#^\.topbloke/##;
+       next if $known_metadata{$_};
+       m/-$/ or die "found unsupported metadata in $ref; you must upgrade\n";
+       $code->();
+           },
+           qw(ls-tree --name-only -r HEAD: .topbloke));
+}
+

 sub check_clean_tree ($) {
     run_git_check_nooutput("operation requires working tree to be clean",
                           qw(diff --name-only HEAD --));
 sub check_clean_tree ($) {
     run_git_check_nooutput("operation requires working tree to be clean",
                           qw(diff --name-only HEAD --));


@@ -186,11 +204,14 @@ sub check_clean_tree ($) {
                           qw(diff --cached --name-only HEAD --));
 }
 
                           qw(diff --cached --name-only HEAD --));
 }
 

+$known_metadata{$_}=1 foreach qw(msg patch base deps deleted
+                                 +included +ends);
+

 #----- configuring a tree -----
 
 sub setup_config () {
 #----- configuring a tree -----
 
 sub setup_config () {

-    my (@files) = (qw(msg patch base deps deleted topgit- lwildcard-
-                      +included +ends +iwildcard-));
+    my (@files) = (qw(lwildcard- msg patch base deps deleted
+                      +iwildcard- +included +ends));

     my $version = 1;
     my $drvname = sub {
        my ($file) = @_;
     my $version = 1;
     my $drvname = sub {
        my ($file) = @_;


@@ -225,32 +246,36 @@ sub setup_config () {
                $pat = ($file =~ m/^\+/ ? '+' : '[^+]').'*';
                $check =~ s/\w.*/xxxunknown/ or die;
            }
                $pat = ($file =~ m/^\+/ ? '+' : '[^+]').'*';
                $check =~ s/\w.*/xxxunknown/ or die;
            }

+           $pat = ".topbloke/$pat";
+           $check = ".topbloke/$check";

            my $want = "topbloke-".$drvname->($file);
            $attrs .= "$pat\tmerge=$want\n";
            my $current = run_git_1line(qw(check-attr merge), $check);
            $current =~ s#^\Q$check\E: merge: ## or die "$file $current ?";
            next if $current eq $want;
            my $want = "topbloke-".$drvname->($file);
            $attrs .= "$pat\tmerge=$want\n";
            my $current = run_git_1line(qw(check-attr merge), $check);
            $current =~ s#^\Q$check\E: merge: ## or die "$file $current ?";
            next if $current eq $want;

-           die "$file $current ?" unless $current eq 'unspecified';
+           die "$file $current ?" unless 
+               $current eq 'unspecified' ||
+               $current =~ m/^topbloke-\wwildcard$/;

            push @needupdate, "$file=$current";
        }
        if (@needupdate) {
            push @needupdate, "$file=$current";
        }
        if (@needupdate) {

+           $attrsfile = git_dir()."/info/attributes";

            my $newattrsf = new IO::File "$attrsfile.tmp", 'w'
                    or die "$attrsfile.tmp: $!";
            die "@needupdate ?" if $iteration;
            my $newattrsf = new IO::File "$attrsfile.tmp", 'w'
                    or die "$attrsfile.tmp: $!";
            die "@needupdate ?" if $iteration;

-           $attrsfile = git_dir()."/info/attributes";

            if (!open OA, '<', "$attrsfile") {
                die "$attrsfile $!" unless $!==ENOENT;
            } else {
                while (<OA>) {
                    next if m#^\.topbloke/#;
                    print $newattrsf $_ or die $!;
            if (!open OA, '<', "$attrsfile") {
                die "$attrsfile $!" unless $!==ENOENT;
            } else {
                while (<OA>) {
                    next if m#^\.topbloke/#;
                    print $newattrsf $_ or die $!;

-                   print "\n" or die $! unless chomp;
+                   print $newattrsf "\n" or die $! unless chomp;

                }
                die $! if OA->error;
                die $! unless close OA;
            }
                }
                die $! if OA->error;
                die $! unless close OA;
            }

-           print $newattrsf or die $!;
-           close $newattrs or die $!;
+           print $newattrsf $attrs or die $!;
+           close $newattrsf or die $!;

            rename "$attrsfile.tmp", "$attrsfile" or die $!;
        }
     }
            rename "$attrsfile.tmp", "$attrsfile" or die $!;
        }
     }


@@ -274,7 +299,7 @@ sub current_branch () {
     }
     if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
        my $fullname = "$2\@$3/$4/$'";
     }
     if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
        my $fullname = "$2\@$3/$4/$'";

-       return {
+       my $v = {

            Kind => $1,
            Email => $2,
            Domain => $3,
            Kind => $1,
            Email => $2,
            Domain => $3,


@@ -284,11 +309,12 @@ sub current_branch () {
            DepSpec => $fullname,
            Fullname => $fullname,
        };
            DepSpec => $fullname,
            Fullname => $fullname,
        };

+       return $v;

     } elsif ($ref =~ m#^refs/heads/#) {
        return {
            Kind => 'foreign',
            Ref => $ref,
     } elsif ($ref =~ m#^refs/heads/#) {
        return {
            Kind => 'foreign',
            Ref => $ref,

-           DepSpec => ".f $ref",
+           DepSpec => "- $ref",

        };
     } else {
        return {
        };
     } else {
        return {


@@ -319,7 +345,7 @@ sub parse_patch_name ($) {
 sub parse_patch_spec ($) {
     my ($orig) = @_;
     local $_ = $orig;
 sub parse_patch_spec ($) {
     my ($orig) = @_;
     local $_ = $orig;

-    die 'FORMAT has new spec syntax nyi';
+    warn 'FORMAT has new spec syntax nyi';

     my $spec = { }; # Email Domain DatePrefix DateNear Nick
     my $set = sub {
        my ($key,$val,$whats) = @_;
     my $spec = { }; # Email Domain DatePrefix DateNear Nick
     my $set = sub {
        my ($key,$val,$whats) = @_;


@@ -454,20 +480,53 @@ sub foreach_patch ($$$$) {
 
 #----- updating topbloke metadata -----
 
 
 #----- updating topbloke metadata -----
 

-sub depssfile_add_dep ($$) {
-    my ($depsfile, $depspec) = @_;
-    my $wf = wf_start(".topbloke/$depsfile");
-    open FI, '<', ".topbloke/$depsfile" or die $!;
-    while (<FI>) {
-       chomp or die;
-       die "dep $depspec already set in $depsfile ?!" if $_ eq $depspec;
-       wf($wf, "$_\n");
+sub metafile_process ($$$$$) {
+    my ($metafile, $startcode, $linecode, $endcode, $enoentcode) = @_;
+    # runs $startcode->($outwf) at start
+    # runs $linecode->($outwf) for each old line, with $_ the chomped line
+    #   may modify $_, which will be written to $outf
+    # at end runs $endcode->($outwf);
+    # runs $enoentcode->($outwf) instead of ever calling $linecode
+    #  if the existing file does not exist;
+    #  if it's false dies instead
+    # any of these may return false, in which case we quit immediately
+    # any of these except enoentcode may be undef to mean "noop"
+    # if they all return true, we install the new file
+    my $wf = wf_start(".topbloke/$metafile");
+    my $call = sub {
+       return 1 unless $_->[0];
+       return 1 if $_->[0]($wf);
+       wf_abort($wf);
+       close FI;
+       return 0;
+    };
+    return unless $call->($startcode);
+    if (!open FI, '<', ".topbloke/$metafile") {
+       die "$metafile $!" unless $!==ENOENT;
+       die "$metafile $!" unless $enoentcode;
+       return unless $call->($enoentcode);
+    } else {
+       while (<FI>) {
+           chomp or die;
+           return unless $call->($linecode);
+           wf($wf, "$_\n");
+       }
+       FI->error and die $!;
+       close FI or die $!;

     }
     }

-    FI->error and die $!;
-    close FI or die $!;
-    wf($wf, "$depspec\n");
+    return unless $call->($endcode);

     wf_done($wf);
 }
     wf_done($wf);
 }

+    
+
+sub depsfile_add_dep ($$) {
+    my ($depsfile, $depspec) = @_;
+    metafile_process($depsfile, undef, sub {
+       die "dep $depspec already set in $depsfile ?!" if $_ eq $depspec;
+    }, sub {
+       wf($_->[0], "$depspec\n");
+    }, undef);
+}

 
 #----- general utilities -----
 
 
 #----- general utilities -----
 

diff --git a/tb-create.pl b/tb-create.pl
index b01010b8333172c0af35bcf60b0ce0d910a3e83c..3a9afc311112826f9367c2c0e59358937702e995 100755 (executable)
--- a/tb-create.pl
+++ b/tb-create.pl
@@ -1,16 +1,12 @@
 #!/usr/bin/perl
 # usage: tb-create <patch-spec>
 
 #!/usr/bin/perl
 # usage: tb-create <patch-spec>
 

-xxx needs updating for new metadata and new theory
-

 use warnings;
 use strict;
 
 use Getopt::Long;
 use Topbloke;
 
 use warnings;
 use strict;
 
 use Getopt::Long;
 use Topbloke;
 

-fixme needs update to new metadata;
-

 Getopt::Long::Configure(qw(bundling));
 
 die "bad usage\n" unless @ARGV==1;
 Getopt::Long::Configure(qw(bundling));
 
 die "bad usage\n" unless @ARGV==1;


@@ -18,11 +14,8 @@ die "bad usage\n" unless @ARGV==1;
 our $spec = parse_patch_spec($ARGV[0]);
 our $current = current_branch();
 
 our $spec = parse_patch_spec($ARGV[0]);
 our $current = current_branch();
 

-die "cannot make patch starting at base of another;".
-    " check out a real branch or patch\n" if $current->{Kind} eq 'base';
-
-die "strange branch ref $current->{Kind} $current->{Ref},\n".
-    " making new patch with this as dep is unwise\n"
+die "strange branch ref $current->{Ref} is of kind $current->{Kind},\n".
+    " making new patch with this as dep is not supported\n"

     unless ($current->{Kind} eq 'foreign' ||
            $current->{Kind} eq 'tip');
 
     unless ($current->{Kind} eq 'foreign' ||
            $current->{Kind} eq 'tip');
 


@@ -50,9 +43,6 @@ length($spec->{Date})==18 or die "partial date specified, not supported\n";
 
 chdir_toplevel();
 
 
 chdir_toplevel();
 

-check_no_unwanted_metadata('HEAD')
-    if $current->{Kind} ne 'tip';
-

 run_git_check_nooutput("cannot create new patch with staged file(s)",
                       qw(diff --cached --name-only HEAD --));
 
 run_git_check_nooutput("cannot create new patch with staged file(s)",
                       qw(diff --cached --name-only HEAD --));
 


@@ -63,9 +53,6 @@ run_git_check_nooutput("cannot create new patch with".
 # For the metadata files in .topbloke, we hope that the user
 # doesn't modify them.  If they do then they get to keep all the pieces.
 #
 # For the metadata files in .topbloke, we hope that the user
 # doesn't modify them.  If they do then they get to keep all the pieces.
 #

-# For .topbloke/msg, if it's modified by the user (ie, if working
-# version differs from HEAD) we keep that and stage it.
-

 my $newpatch = "$spec->{Email}\@$spec->{Domain}/$spec->{Date}/$spec->{Nick}";
 
 $newpatch = run_git_1line(qw(check-ref-format --print), $newpatch);
 my $newpatch = "$spec->{Email}\@$spec->{Domain}/$spec->{Date}/$spec->{Nick}";
 
 $newpatch = run_git_1line(qw(check-ref-format --print), $newpatch);


@@ -99,6 +86,11 @@ sub meta_and_stage ($$) {
     stage_meta($file);
 }
 
     stage_meta($file);
 }
 

+sub meta_rm_stage ($) {
+    my ($file) = @_;
+    run_git(qw(rm --ignore-unmatch -q --), ".topbloke/$file");
+}
+

 #----- create the base branch
 
 if (lstat '.topbloke') {
 #----- create the base branch
 
 if (lstat '.topbloke') {


@@ -107,23 +99,47 @@ if (lstat '.topbloke') {
     mkdir('.topbloke') or die "create .topbloke: $!\n";
 }
 
     mkdir('.topbloke') or die "create .topbloke: $!\n";
 }
 

-my $baseref = "refs/topbloke-bases/$newpatch";
+my @meta_to_rm;
+
+if ($current->{Kind} eq 'foreign') {
+    check_no_metadata('HEAD');
+} else {
+    foreach_unknown_metadata('HEAD', 
+                            sub { push @meta_to_rm, $_ unless m/^\+/; });
+}
+
+my $baseref = "$baserefs/$newpatch";
+my $currentcommit = run_git_1line(qw(rev-parse), "HEAD");

 create_and_switch($baseref, 'base');
 
 create_and_switch($baseref, 'base');
 

-meta_and_stage('msg', "# not applicable\n");
-meta_and_stage('deps', "");
-meta_and_stage('props', "patch $current->{Fullname}\n");
+meta_rm_stage('msg');
+meta_and_stage('patch', "$newpatch\n");
+meta_rm_stage('base');
+meta_and_stage('deps', "$current->{DepSpec}\n");
+meta_rm_stage('deleted');
+meta_rm_stage($_) foreach @meta_to_rm;

 
 if ($current->{Kind} eq 'foreign') {
 
 if ($current->{Kind} eq 'foreign') {

-    meta_and_stage('included', $current->{DepSpec}."\n");
-    meta_and_stage('pprops', '');
+    meta_and_stage('+included', "");
+    meta_and_stage('+ends', "");
+} else {
+    # we inherit correct contents for +included
+    if ($current->{Kind} eq 'tip') {
+       metafile_process('+ends', undef, sub {
+           die if m/^\Q$current->{Fullname}\E /;
+        }, sub {
+           wf($_->[0], "$current->{Fullname} $currentcommit\n");
+        }, undef);
+       stage_meta('+ends');
+    }

 }
 
 run_git(qw(commit -q -m), "tb-create $newpatch base");
 }
 
 run_git(qw(commit -q -m), "tb-create $newpatch base");

+my $basecommit = run_git_1line(qw(rev-parse), "$baseref~0");

 
 #----- create the tip branch
 
 
 #----- create the tip branch
 

-my $tipref = "refs/topbloke-tips/$newpatch";
+my $tipref = "$tiprefs/$newpatch";

 create_and_switch($tipref, 'tip');
 
 my $nm = wf_start('.topbloke/msg');
 create_and_switch($tipref, 'tip');
 
 my $nm = wf_start('.topbloke/msg');


@@ -144,10 +160,9 @@ END
 wf_done($nm);
 stage_meta('msg');
 
 wf_done($nm);
 stage_meta('msg');
 

-meta_and_stage('deps', "$current->{DepSpec}\n");
-# we inherit correct props and pprops from the base branch
-
-depsfile_add_dep('included','tb',$newpatch);
-stage_meta('included');
+meta_and_stage('base', "$basecommit\n");
+meta_rm_stage('deps');
+depsfile_add_dep('+included',$newpatch);
+stage_meta('+included');

 
 run_git(qw(commit -q -m), "tb-create $newpatch tip");
 
 run_git(qw(commit -q -m), "tb-create $newpatch tip");