Ticket #359: tt359-pbc_uuid.patch

File tt359-pbc_uuid.patch, 9.3 KB (added by rurban, 6 years ago)

md5 not binary safe?

  • lib/Parrot/BuildUtil.pm

    old new  
    1212 
    1313=head1 DESCRIPTION 
    1414 
    15 This package holds three subroutines:  C<parrot_version()>, C<slurp_file>, 
    16 and C<generated_file_header>. Subroutines are not exported--each must be 
    17 requested by using a fully qualified name. 
     15This package holds pre-configure time subroutines, which are not exported 
     16and should not require Parrot::Config. 
     17Each must be requested by using a fully qualified name. 
    1818 
    1919=head1 SUBROUTINES 
    2020 
     
    134134    return $header; 
    135135} 
    136136 
    137 1; 
     137=item C<generate_pbc_fingerprint()> 
    138138 
    139 =back 
     139Generate a unique number, the md5 of F<PBC_COMPAT>, 
     140for each pbc format change. The length (12) influences 
     141the header layout. 
     142 
     143This is used in the packfile library. 
     144See also F<tools/dev/pbc_header.pl> 
     145 
     146=cut 
     147 
     148sub generate_pbc_fingerprint { 
     149 
     150    unless (eval { require Digest::MD5; }) { 
     151        warn "Digest::MD5 not found. Skipping fingerprint"; 
     152        return ''; 
     153    } 
     154    my $content = slurp_file('PBC_COMPAT'); 
     155    $content =~ s/^#.*\n//gm; 
     156    $content =~ s/^\n//gm; 
     157    my $fingerprint = Digest::MD5::md5($content); 
     158    return substr $fingerprint, 0, 12; 
     159} 
     160 
     161=item C<get_bc_version()> 
     162 
     163Return an array of ($bc_major, $bc_minor) from F<PBC_COMPAT>. 
     164This is used to generate the pbc_uuid. 
    140165 
    141 =head1 AUTHOR 
     166See also F<tools/dev/pbc_header.pl> and F<tools/build/pbcversion_h.pl>. 
    142167 
    143 Gregor N. Purdy.  Revised by James E Keenan. 
     168=cut 
     169 
     170sub get_bc_version { 
     171    my $compat_file = 'PBC_COMPAT'; 
     172    my ( $bc_major, $bc_minor ); 
     173    open my $IN, '<', $compat_file or die "Can't read $compat_file"; 
     174    while (<$IN>) { 
     175        if (/^(\d+)\.0*(\d+)/) { 
     176            ( $bc_major, $bc_minor ) = ( $1, $2 ); 
     177            last; 
     178        } 
     179    } 
     180    unless ( defined $bc_major && defined $bc_minor ) { 
     181        die "No bytecode version found in '$compat_file'."; 
     182    } 
     183    close $IN; 
     184    return ( $bc_major, $bc_minor ); 
     185} 
     186 
     187 
     1881; 
     189 
     190=back 
    144191 
    145192=cut 
    146193 
  • tools/dev/pbc_header.pl

    old new  
    3636=cut 
    3737 
    3838use Getopt::Long; 
    39 use Digest::MD5 qw(md5); 
     39use lib "lib"; 
     40use Parrot::BuildUtil; 
    4041 
    4142my %opt; 
    42 use constant FP_LEN => 12; 
    4343my $word_size = 4; 
    4444 
    4545main(); 
    4646 
    47 sub get_fp { 
    48  
    49     # s. also fingerprint_c.pl 
    50     my $compat_file = 'PBC_COMPAT'; 
    51     open my $IN, '<', $compat_file or die "Can't read $compat_file"; 
    52     my @lines = <$IN>; 
    53     close $IN; 
    54  
    55     my $len = FP_LEN; 
    56     my $fingerprint = md5 join "\n", grep { !/^#/ } @lines; 
    57  
    58     return substr $fingerprint, 0, $len; 
    59 } 
    60  
    6147sub get_version { 
    6248    my $version_file = 'VERSION'; 
    6349    open my $IN, '<', $version_file or die "Can't read $version_file"; 
     
    8773sub update_fp { 
    8874    my (@args) = @_; 
    8975 
    90     my $fp = get_fp(); 
     76    my $fp = Parrot::BuildUtil::generate_pbc_fingerprint(); 
     77    my $fp_len = length $fp; 
    9178    my ( $major, $minor, $patch ) = get_version(); 
    9279    my ( $bc_major, $bc_minor ) = get_bc_version(); 
    9380    for my $f (@args) { 
     
    10491        # uuid_type = 1, uuid_size = 10, uuid_data = $fp 
    10592        read $F, $b, 8; 
    10693        my ($type, $uuid_len) = unpack "cc", $b; 
    107         if ($type != 1 or $uuid_len != FP_LEN) { 
     94        if ($type != 1 or $uuid_len != $fp_len) { 
    10895            # if uuid_type was 0 or of different size copy the tail first 
    10996            my $leftover = (18 + $uuid_len) % 16; 
    11097            my $n = $leftover == 0 ? 0 : 16 - $leftover; 
    111             # we can skip the copy if there's enough room already (pad:14=>2) 
    112             goto SEEK if $n < FP_LEN; 
     98            # we can skip the copy if there's enough room already (pad: 14=>2) 
     99            goto SEEK if $n > $fp_len; 
    113100            my $dirstart = 18 + $uuid_len + $n; 
    114101            seek $F, $dirstart, 0;   # skip to dir 
    115102            my $size = -s $F; 
     
    119106        } 
    120107      SEEK: 
    121108        seek $F, 16, 0;   # back to pos 16: uuid_type, uuid_size 
    122         print $F pack "cc", 1, FP_LEN; 
     109        print $F pack "cc", 1, $fp_len; 
    123110        print $F $fp; 
    124111        close $F; 
    125112    } 
  • config/gen/config_h/config_h.in

    old new  
    9494#define PARROT_BYTEORDER        0x@byteorder@ 
    9595#define PARROT_BIGENDIAN        @bigendian@ 
    9696#define PARROT_PTR_ALIGNMENT    @ptr_alignment@ 
     97#define PARROT_PBC_UUID         "@pbc_uuid@" 
    9798 
    9899#define PARROT_LITTLEENDIAN     !(PARROT_BIGENDIAN) 
    99100 
  • src/packfile.c

    old new  
    12451245#    endif 
    12461246#  endif 
    12471247#endif 
     1248    if (*PARROT_PBC_UUID) { 
     1249        header->uuid_type = 1; 
     1250        header->uuid_size = sizeof(PARROT_PBC_UUID); 
     1251        header->uuid_data = (unsigned char *)PARROT_PBC_UUID; 
     1252        mem_sys_allocate(header->uuid_size + 1); 
     1253        memcpy(header->uuid_data, PARROT_PBC_UUID, header->uuid_size); 
     1254        /* NULL terminate */ 
     1255        header->uuid_data[header->uuid_size] = 0; 
     1256    } 
    12481257} 
    12491258 
    12501259 
  • Configure.pl

    old new  
    6464# from Parrot::Configure::Data 
    6565$conf->options->set( %{$args} ); 
    6666# save the command-line for make reconfig 
    67 $conf->data->set(configure_args => @ARGV ? '"'.join("\" \"", map {qq($_)} @ARGV).'"' 
    68                                          : ''); 
     67$conf->data->set(configure_args => 
     68                 @ARGV ? '"'.join("\" \"", map {qq($_)} @ARGV).'"' 
     69                       : ''); 
    6970 
    7071# Log files created by Configure.pl in MANIFEST.configure.generated 
    7172$conf->{active_configuration} = 1; 
  • config/auto/pmc.pm

    old new  
    99 
    1010Asks the user to select which PMC files to include. 
    1111 
     12Generate a specific UUID for this selection then, 
     13for the default use the md5 of PBC_COMPAT. 
     14 
    1215=cut 
    1316 
    1417package auto::pmc; 
     
    2225use File::Spec::Functions qw/catfile/; 
    2326 
    2427use Parrot::Configure::Utils ':auto'; 
     28use Parrot::BuildUtil; 
    2529 
    2630sub _init { 
    2731    my $self = shift; 
     
    168172 
    169173    my @names = $self->order_pmcs_by_hierarchy( \%parents ); 
    170174 
     175    # Generate a specific UUID for user-defined pmc's and ops 
     176    # auto::ops runs before auto::pmc, so do it here. 
     177    my $pbc_uuid = ''; 
     178    if ($conf->options->get('pmc') or $conf->options->get('ops')) { 
     179        unless (eval { require Digest::MD5; }) { 
     180            warn "Digest::MD5 not found. Skipping fingerprint"; 
     181        } 
     182        else { 
     183            my ( $major, $minor ) = Parrot::BuildUtil::get_bc_version(); 
     184            my $ops = $conf->data->get( 'ops' ); 
     185            my $fp = join( ' ', @names ) . " ". $ops . " " . $major . " " . $minor; 
     186            $pbc_uuid = substr Digest::MD5::md5( $fp ), 0, 12; 
     187        } 
     188    } 
     189    else { # use the default UUID. This requires PBC_COMPAT discipline 
     190        $pbc_uuid = Parrot::BuildUtil::generate_pbc_fingerprint(); 
     191    } 
     192 
    171193    $conf->data->set( 
    172194        pmc                  => $pmc_list, 
    173195        pmc_names            => join( ' ', @names ), 
     196        pbc_uuid             => $pbc_uuid, 
    174197        TEMP_pmc_o           => $TEMP_pmc_o, 
    175198        TEMP_pmc_build       => $TEMP_pmc_build, 
    176199        TEMP_pmc_classes_o   => $TEMP_pmc_classes_o, 
  • tools/build/pbcversion_h.pl

    old new  
    2121use warnings; 
    2222use strict; 
    2323use lib 'lib'; 
     24use Parrot::BuildUtil; 
    2425 
    25 my ( $major, $minor ); 
    26  
    27 my $compat_file = 'PBC_COMPAT'; 
    28 open my $IN, '<', $compat_file or die "Can't read $compat_file"; 
    29 while (<$IN>) { 
    30     if (/^(\d+)\.0*(\d+)/) { 
    31         ( $major, $minor ) = ( $1, $2 ); 
    32         last; 
    33     } 
    34 } 
    35 close $IN; 
    36  
    37 unless ( defined $major && defined $minor ) { 
    38     die "No bytecode version found in '$compat_file'."; 
    39 } 
     26my ( $major, $minor ) = Parrot::BuildUtil::get_bc_version(); 
    4027 
    4128print << "EOF"; 
    4229/* ex: set ro: 
    4330 * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
    4431 * 
    45  * This file is generated automatically from '$compat_file' 
     32 * This file is generated automatically from 'PBC_COMPAT' 
    4633 * by $0. 
    4734 * 
    4835 * Any changes made here will be lost! 
  • config/auto/ops.pm

    old new  
    99 
    1010Asks the user to select which ops files to include. 
    1111 
     12Generate a specific UUID for this selection in auto::pmc then. 
     13 
    1214=cut 
    1315 
    1416package auto::ops;