Ticket #359: tt359-pbc_uuid.2.patch

lib/Parrot/BuildUtil.pm

@@ -12 +12 @@
 
 =head1 DESCRIPTION
 
-This package holds three subroutines:  C<parrot_version()>, C<slurp_file>,
-and C<generated_file_header>. Subroutines are not exported--each must be
-requested by using a fully qualified name.
+This package holds pre-configure time subroutines, which are not exported
+and should not require Parrot::Config.
+Each must be requested by using a fully qualified name.
 
 =head1 SUBROUTINES
 
@@ -134 +134 @@
     return $header;
 }
 
-1;
+=item C<generate_pbc_fingerprint()>
 
-=back
+Generate a unique number, the md5 of either the given arguments or
+of the non-commented lines of F<PBC_COMPAT>, for each pbc format change.
+
+This is used in the packfile library.
+See also F<tools/dev/pbc_header.pl>
+
+=cut
+
+sub generate_pbc_fingerprint {
+
+    unless (eval { require Digest::MD5; }) {
+        warn "Digest::MD5 not found. Skipping fingerprint";
+        return '';
+    }
+    my $uuid;
+    if (@_) {
+        $uuid = Digest::MD5::md5_base64(join " ", @_);
+    }
+    else {
+        my $content = slurp_file('PBC_COMPAT');
+        $content =~ s/^#.*\n//gm;
+        $content =~ s/^\n//gm;
+        $uuid = Digest::MD5::md5_base64($content);
+    }
+    return substr $uuid, 0, 22;
+}
+
+=item C<get_bc_version()>
+
+Return an array of ($bc_major, $bc_minor) from F<PBC_COMPAT>.
+This is used to generate the pbc_uuid.
 
-=head1 AUTHOR
+See also F<tools/dev/pbc_header.pl> and F<tools/build/pbcversion_h.pl>.
 
-Gregor N. Purdy.  Revised by James E Keenan.
+=cut
+
+sub get_bc_version {
+    my $compat_file = 'PBC_COMPAT';
+    my ( $bc_major, $bc_minor );
+    open my $IN, '<', $compat_file or die "Can't read $compat_file";
+    while (<$IN>) {
+        if (/^(\d+)\.0*(\d+)/) {
+            ( $bc_major, $bc_minor ) = ( $1, $2 );
+            last;
+        }
+    }
+    unless ( defined $bc_major && defined $bc_minor ) {
+        die "No bytecode version found in '$compat_file'.";
+    }
+    close $IN;
+    return ( $bc_major, $bc_minor );
+}
+
+
+1;
+
+=back
 
 =cut
 

tools/dev/pbc_header.pl

@@ -36 +36 @@
 =cut
 
 use Getopt::Long;
-use Digest::MD5 qw(md5);
+use lib "lib";
+use Parrot::BuildUtil;
 
 my %opt;
-use constant FP_LEN => 12;
-my $word_size = 4;
+my $word_size = 4; # fixed and not opcode_t_size !
 
 main();
 
-sub get_fp {
-
-    # s. also fingerprint_c.pl
-    my $compat_file = 'PBC_COMPAT';
-    open my $IN, '<', $compat_file or die "Can't read $compat_file";
-    my @lines = <$IN>;
-    close $IN;
-
-    my $len = FP_LEN;
-    my $fingerprint = md5 join "\n", grep { !/^#/ } @lines;
-
-    return substr $fingerprint, 0, $len;
-}
-
-sub get_version {
-    my $version_file = 'VERSION';
-    open my $IN, '<', $version_file or die "Can't read $version_file";
-    my $v = <$IN>;
-    close $IN;
-    $v =~ /^(\d+)\.(\d+).?(\d+)?/;
-    my ($major, $minor, $patch) = ($1, $2, $3 ? $3 : 0);
-    die "Can't read $version_file" unless defined $major;
-    return ( $major, $minor, $patch );
-}
-
-sub get_bc_version {
-    my $compat_file = 'PBC_COMPAT';
-    my ( $major, $minor );
-    open my $IN, '<', $compat_file or die "Can't read $compat_file";
-    while (<$IN>) {
-        if (/^(\d+)\.0*(\d+)/) {
-            ( $major, $minor ) = ( $1, $2 );
-            last;
-        }
-    }
-    die "Can't read $compat_file" unless defined $major;
-    close $IN;
-    return ( $major, $minor );
-}
-
 sub update_fp {
     my (@args) = @_;
 
-    my $fp = get_fp();
-    my ( $major, $minor, $patch ) = get_version();
-    my ( $bc_major, $bc_minor ) = get_bc_version();
+    my $fp = Parrot::BuildUtil::generate_pbc_fingerprint();
+    my $fp_len = length $fp;
+    my ( $major, $minor, $patch ) = Parrot::BuildUtil::parrot_version();
+    my ( $bc_major, $bc_minor ) = Parrot::BuildUtil::get_bc_version();
     for my $f (@args) {
         my $b;
         open my $F, "+<", "$f" or die "Can't open $f: $!";
@@ -104 +65 @@
         # uuid_type = 1, uuid_size = 10, uuid_data = $fp
         read $F, $b, 8;
         my ($type, $uuid_len) = unpack "cc", $b;
-        if ($type != 1 or $uuid_len != FP_LEN) {
+        if ($type != 1 or $uuid_len != $fp_len) {
             # if uuid_type was 0 or of different size copy the tail first
             my $leftover = (18 + $uuid_len) % 16;
             my $n = $leftover == 0 ? 0 : 16 - $leftover;
-            # we can skip the copy if there's enough room already (pad:14=>2)
-            goto SEEK if $n < FP_LEN;
+            # we can skip the copy if there's enough room already (pad: 14=>2)
+            goto SEEK if $n > $fp_len;
             my $dirstart = 18 + $uuid_len + $n;
             seek $F, $dirstart, 0;   # skip to dir
             my $size = -s $F;
@@ -119 +80 @@
         }
       SEEK:
         seek $F, 16, 0;   # back to pos 16: uuid_type, uuid_size
-        print $F pack "cc", 1, FP_LEN;
+        print $F pack "cc", 1, $fp_len;
         print $F $fp;
         close $F;
     }

config/gen/config_h/config_h.in

@@ -94 +94 @@
 #define PARROT_BYTEORDER        0x@byteorder@
 #define PARROT_BIGENDIAN        @bigendian@
 #define PARROT_PTR_ALIGNMENT    @ptr_alignment@
+#define PARROT_PBC_UUID         "@pbc_uuid@"
 
 #define PARROT_LITTLEENDIAN     !(PARROT_BIGENDIAN)
 

src/packfile.c

@@ -981 +981 @@
                           : FLOATTYPE_12_NAME));
     TRACE_PRINTF(("PackFile_unpack: Byteorder %d (%sendian).\n",
                   header->byteorder, header->byteorder ? "big " : "little-"));
-
+    TRACE_PRINTF(("PackFile_unpack: uuid_type=%d\n", header->uuid_type));
+    TRACE_PRINTF(("PackFile_unpack: uuid_size=%d\n", header->uuid_size));
     /* Check the UUID type is valid and, if needed, read a UUID. */
     if (header->uuid_type == 0) {
         /* No UUID; fine, nothing more to do. */
     }
     else if (header->uuid_type == 1) {
         /* Read in the UUID. We'll put it in a NULL-terminated string, just in
-         * case pepole use it that way. */
+         * case people use it that way. */
         header->uuid_data = (unsigned char *)
             mem_sys_allocate(header->uuid_size + 1);
 
-        memcpy(header->uuid_data, packed + PACKFILE_HEADER_BYTES,
-            header->uuid_size);
-
+        memcpy(header->uuid_data, PARROT_PBC_UUID, header->uuid_size);
         /* NULL terminate */
         header->uuid_data[header->uuid_size] = 0;
+        TRACE_PRINTF(("PackFile_unpack: uuid_data='%s'\n", header->uuid_data));
     }
     else
         /* Don't know this UUID type. */
@@ -1009 +1009 @@
     header_read_length += header_read_length % 16 ?
         16 - header_read_length % 16 : 0;
     cursor              = packed + (header_read_length / sizeof (opcode_t));
+    TRACE_PRINTF(("PackFile_unpack: pad=%d\n",
+                  cursor - packed));
 
     /* Set what transforms we need to do when reading the rest of the file. */
     PackFile_assign_transforms(self);
@@ -1244 +1246 @@
 #    endif
 #  endif
 #endif
+    if (strlen(PARROT_PBC_UUID)) {
+        header->uuid_type = 1;
+        header->uuid_size = strlen(PARROT_PBC_UUID);
+        header->uuid_data = (unsigned char *)mem_sys_allocate(header->uuid_size + 1);
+        memcpy(header->uuid_data, PARROT_PBC_UUID, header->uuid_size);
+        /* NULL terminate */
+        header->uuid_data[header->uuid_size] = 0;
+    }
 }
 
 
@@ -3482 +3492 @@
     ep->type = type;
     ep->name = name;
 
-    if (PackFile_map_segments(interp, dir, find_fixup_iter, (void *) ep));
+    if (PackFile_map_segments(interp, dir, find_fixup_iter, (void *) ep))
         return ep;
 
     return NULL;

Configure.pl

@@ -64 +64 @@
 # from Parrot::Configure::Data
 $conf->options->set( %{$args} );
 # save the command-line for make reconfig
-$conf->data->set(configure_args => @ARGV ? '"'.join("\" \"", map {qq($_)} @ARGV).'"'
-                                         : '');
+$conf->data->set(configure_args =>
+                 @ARGV ? '"'.join("\" \"", map {qq($_)} @ARGV).'"'
+                       : '');
 
 # Log files created by Configure.pl in MANIFEST.configure.generated
 $conf->{active_configuration} = 1;

config/auto/pmc.pm

@@ -9 +9 @@
 
 Asks the user to select which PMC files to include.
 
+Generate a specific UUID for this selection then,
+for the default use the md5 of PBC_COMPAT.
+
 =cut
 
 package auto::pmc;
@@ -22 +25 @@
 use File::Spec::Functions qw/catfile/;
 
 use Parrot::Configure::Utils ':auto';
+use Parrot::BuildUtil;
 
 sub _init {
     my $self = shift;
@@ -168 +172 @@
 
     my @names = $self->order_pmcs_by_hierarchy( \%parents );
 
+    # Generate a specific UUID for user-defined pmc's and ops
+    # auto::ops runs before auto::pmc, so do it here.
+    my $pbc_uuid = '';
+    if ($conf->options->get('pmc') or $conf->options->get('ops')) {
+        unless (eval { require Digest::MD5; }) {
+            warn "Digest::MD5 not found. Skipping fingerprint";
+        }
+        else {
+            my ( $major, $minor ) = Parrot::BuildUtil::get_bc_version();
+            my @sources = (@names, $major, $minor);
+            my $ops = $conf->data->get( 'ops' );
+            push @sources, $ops if $ops;
+            $pbc_uuid = Parrot::BuildUtil::generate_pbc_fingerprint(@sources);
+        }
+    }
+    else { # use the default UUID. This requires PBC_COMPAT discipline
+        $pbc_uuid = Parrot::BuildUtil::generate_pbc_fingerprint();
+    }
+
     $conf->data->set(
         pmc                  => $pmc_list,
         pmc_names            => join( ' ', @names ),
+        pbc_uuid             => $pbc_uuid,
         TEMP_pmc_o           => $TEMP_pmc_o,
         TEMP_pmc_build       => $TEMP_pmc_build,
         TEMP_pmc_classes_o   => $TEMP_pmc_classes_o,

tools/build/pbcversion_h.pl

@@ -21 +21 @@
 use warnings;
 use strict;
 use lib 'lib';
+use Parrot::BuildUtil;
 
-my ( $major, $minor );
-
-my $compat_file = 'PBC_COMPAT';
-open my $IN, '<', $compat_file or die "Can't read $compat_file";
-while (<$IN>) {
-    if (/^(\d+)\.0*(\d+)/) {
-        ( $major, $minor ) = ( $1, $2 );
-        last;
-    }
-}
-close $IN;
-
-unless ( defined $major && defined $minor ) {
-    die "No bytecode version found in '$compat_file'.";
-}
+my ( $major, $minor ) = Parrot::BuildUtil::get_bc_version();
 
 print << "EOF";
 /* ex: set ro:
  * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  *
- * This file is generated automatically from '$compat_file'
+ * This file is generated automatically from 'PBC_COMPAT'
  * by $0.
  *
  * Any changes made here will be lost!

config/auto/ops.pm

@@ -9 +9 @@
 
 Asks the user to select which ops files to include.
 
+Generate a specific UUID for this selection in auto::pmc then.
+
 =cut
 
 package auto::ops;