Ticket #359: tt359-pbc_uuid.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 F<PBC_COMPAT>,
+for each pbc format change. The length (12) influences
+the header layout.
+
+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 $content = slurp_file('PBC_COMPAT');
+    $content =~ s/^#.*\n//gm;
+    $content =~ s/^\n//gm;
+    my $fingerprint = Digest::MD5::md5($content);
+    return substr $fingerprint, 0, 12;
+}
+
+=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;
 
 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";
@@ -87 +73 @@
 sub update_fp {
     my (@args) = @_;
 
-    my $fp = get_fp();
+    my $fp = Parrot::BuildUtil::generate_pbc_fingerprint();
+    my $fp_len = length $fp;
     my ( $major, $minor, $patch ) = get_version();
     my ( $bc_major, $bc_minor ) = get_bc_version();
     for my $f (@args) {
@@ -104 +91 @@
         # 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 +106 @@
         }
       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

@@ -1245 +1245 @@
 #    endif
 #  endif
 #endif
+    if (*PARROT_PBC_UUID) {
+        header->uuid_type = 1;
+        header->uuid_size = sizeof(PARROT_PBC_UUID);
+        header->uuid_data = (unsigned char *)PARROT_PBC_UUID;
+        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;
+    }
 }
 
 

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 $ops = $conf->data->get( 'ops' );
+            my $fp = join( ' ', @names ) . " ". $ops . " " . $major . " " . $minor;
+            $pbc_uuid = substr Digest::MD5::md5( $fp ), 0, 12;
+        }
+    }
+    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;