File Coverage

File:lib/Parrot/BuildUtil.pm
Coverage:94.3%

linestmtbrancondsubcode
1# Copyright (C) 2001-2009, Parrot Foundation.
2
3package Parrot::BuildUtil;
4
5
116
116
116
116
use strict;
6
116
116
116
116
use warnings;
7
8 - 33
=head1 NAME

Parrot::BuildUtil - Utilities for building Parrot

=head1 DESCRIPTION

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

=over 4

=item C<parrot_version()>

Determines the current version number for Parrot from the VERSION file
and returns it in a context-appropriate manner.

    $parrot_version = Parrot::BuildUtil::parrot_version();
    # $parrot_version is '0.4.11'

    @parrot_version = Parrot::BuildUtil::parrot_version();
    # @parrot_version is (0, 4, 11)

=cut
34
35# cache for repeated calls
36my ( $parrot_version, @parrot_version );
37
38sub parrot_version {
39
125
100
125
    if ( defined $parrot_version ) {
40
16
100
        return wantarray ? @parrot_version : $parrot_version;
41    }
42
43    # Obtain the official version number from the VERSION file.
44
109
100
    if (-e 'VERSION') {
45
107
50
        open my $VERSION, '<', 'VERSION' or die 'Could not open VERSION file!';
46
107
        chomp( $parrot_version = <$VERSION> );
47
107
50
        close $VERSION or die $!;
48    }
49    else { # we're in an installed copy of Parrot
50
2
        my $path = shift;
51
2
100
        $path = '' unless $path;
52
2
100
        open my $VERSION, '<', "$path/VERSION" or die 'Could not open VERSION file!';
53
1
        chomp( $parrot_version = <$VERSION> );
54
1
50
        close $VERSION or die $!;
55    }
56
57
108
    $parrot_version =~ s/\s+//g;
58
108
    @parrot_version = split( /\./, $parrot_version );
59
60
108
100
    if ( scalar(@parrot_version) < 3 ) {
61
1
        die "Too few components to VERSION file contents: '$parrot_version' (should be 3 or 4)!";
62    }
63
64
107
100
    if ( scalar(@parrot_version) > 4 ) {
65
1
        die "Too many components to VERSION file contents: '$parrot_version' (should be 3 or 4)!";
66    }
67
68
106
    foreach my $component (@parrot_version) {
69
317
100
        die "Illegal version component: '$component' in VERSION file!"
70            unless $component =~ m/^\d+$/;
71    }
72
73
105
    $parrot_version = join( '.', @parrot_version );
74
105
100
    return wantarray ? @parrot_version : $parrot_version;
75}
76
77 - 82
=item C<slurp_file($filename)>

Slurps up the filename and returns the content as one string.  While
doing so, it converts all DOS-style line endings to newlines.

=cut
83
84sub slurp_file {
85
288
288
    my ($file_name) = @_;
86
87
288
100
    open( my $SLURP, '<', $file_name ) or die "open '$file_name': $!";
88
287
    local $/ = undef;
89
287
    my $file = <$SLURP> . '';
90
287
    $file =~ s/\cM\cJ/\n/g;
91
287
50
    close $SLURP or die $!;
92
93
287
    return $file;
94}
95
96 - 103
=item C<generated_file_header($filename, $style)>

Returns a comment to mark a generated file and detail how it was created.
C<$filename> is the name of the file on which the generated file is based,
C<$style> is the style of comment--C<'perl'> and C<'c'> are permitted, other
values produce an error.

=cut
104
105sub generated_file_header {
106
3
3
    my ( $filename, $style ) = @_;
107
108
3
100
100
    die qq{unknown style "$style"}
109        unless ($style eq 'perl' or $style eq 'c');
110
111
2
    require File::Spec;
112
2
    my $script = File::Spec->abs2rel($0);
113
2
    $script =~ s/\\/\//g;
114
115
2
    my $header = <<"END_HEADER";
116/* ex: set ro ft=c:
117 * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
118 *
119 * This file is generated automatically from '$filename'
120 * by $script.
121 *
122 * Any changes made here will be lost!
123 *
124 */
125END_HEADER
126
127
2
100
    if ( $style eq 'perl' ) {
128
1
        $header =~ s/^\/\*(.*?)ft=c:/# $1ft=perl:/;
129
1
        $header =~ s/\n \*\n \*\///;
130
1
        $header =~ s/^ \* ?/# /msg;
131    }
132
133
2
    return $header;
134}
135
136 - 143
=item C<get_bc_version()>

Return an array of ($bc_major, $bc_minor) from F<PBC_COMPAT>.
This is used in the native_pbc tests.

See also F<tools/dev/pbc_header.pl> and F<tools/build/pbcversion_h.pl>.

=cut
144
145sub get_bc_version {
146
2
2
    my $compat_file = 'PBC_COMPAT';
147
2
    my ( $bc_major, $bc_minor );
148
2
50
    open my $IN, '<', $compat_file or die "Can't read $compat_file";
149
2
    while (<$IN>) {
150
2
100
        if (/^(\d+)\.0*(\d+)/) {
151
1
            ( $bc_major, $bc_minor ) = ( $1, $2 );
152
1
            last;
153        }
154    }
155
2
50
    close $IN or die "Couldn't close $compat_file";
156
2
100
    unless ( defined $bc_major ) {
157
1
        die "No bytecode version found in '$compat_file'.";
158    }
159
1
    return ( $bc_major, $bc_minor );
160}
161
1621;
163
164=back
165
166=cut
167
168# Local Variables:
169# mode: cperl
170# cperl-indent-level: 4
171# fill-column: 100
172# End:
173# vim: expandtab shiftwidth=4: