lib/Parrot/BuildUtil.pm

   1 # Copyright (C) 2001-2009, Parrot Foundation.
   2 # $Id$
   3
   4 package Parrot::BuildUtil;
   5
   6 use strict;
   7 use warnings;
   8
   9 =head1 NAME
  10
  11 Parrot::BuildUtil - Utilities for building Parrot
  12
  13 =head1 DESCRIPTION
  14
  15 This package holds pre-configure time subroutines, which are not exported
  16 and should not require Parrot::Config.
  17 Each must be requested by using a fully qualified name.
  18
  19 =head1 SUBROUTINES
  20
  21 =over 4
  22
  23 =item C<parrot_version()>
  24
  25 Determines the current version number for Parrot from the VERSION file
  26 and returns it in a context-appropriate manner.
  27
  28     $parrot_version = Parrot::BuildUtil::parrot_version();
  29     # $parrot_version is '0.4.11'
  30
  31     @parrot_version = Parrot::BuildUtil::parrot_version();
  32     # @parrot_version is (0, 4, 11)
  33
  34 =cut
  35
  36 # cache for repeated calls
  37 my ( $parrot_version, @parrot_version );
  38
  39 sub parrot_version {
  40     if ( defined $parrot_version ) {
  41         return wantarray ? @parrot_version : $parrot_version;
  42     }
  43
  44     # Obtain the official version number from the VERSION file.
  45     if (-e 'VERSION') {
  46         open my $VERSION, '<', 'VERSION' or die 'Could not open VERSION file!';
  47         chomp( $parrot_version = <$VERSION> );
  48         close $VERSION or die $!;
  49     }
  50     else { # we're in an installed copy of Parrot
  51         my $path = shift;
  52         $path = '' unless $path;
  53         open my $VERSION, '<', "$path/VERSION" or die 'Could not open VERSION file!';
  54         chomp( $parrot_version = <$VERSION> );
  55         close $VERSION or die $!;
  56     }
  57
  58     $parrot_version =~ s/\s+//g;
  59     @parrot_version = split( /\./, $parrot_version );
  60
  61     if ( scalar(@parrot_version) < 3 ) {
  62         die "Too few components to VERSION file contents: '$parrot_version' (should be 3 or 4)!";
  63     }
  64
  65     if ( scalar(@parrot_version) > 4 ) {
  66         die "Too many components to VERSION file contents: '$parrot_version' (should be 3 or 4)!";
  67     }
  68
  69     foreach my $component (@parrot_version) {
  70         die "Illegal version component: '$component' in VERSION file!"
  71             unless $component =~ m/^\d+$/;
  72     }
  73
  74     $parrot_version = join( '.', @parrot_version );
  75     return wantarray ? @parrot_version : $parrot_version;
  76 }
  77
  78 =item C<slurp_file($filename)>
  79
  80 Slurps up the filename and returns the content as one string.  While
  81 doing so, it converts all DOS-style line endings to newlines.
  82
  83 =cut
  84
  85 sub slurp_file {
  86     my ($file_name) = @_;
  87
  88     open( my $SLURP, '<', $file_name ) or die "open '$file_name': $!";
  89     local $/ = undef;
  90     my $file = <$SLURP> . '';
  91     $file =~ s/\cM\cJ/\n/g;
  92     close $SLURP or die $!;
  93
  94     return $file;
  95 }
  96
  97 =item C<generated_file_header($filename, $style)>
  98
  99 Returns a comment to mark a generated file and detail how it was created.
 100 C<$filename> is the name of the file on which the generated file is based,
 101 C<$style> is the style of comment--C<'perl'> and C<'c'> are permitted, other
 102 values produce an error.
 103
 104 =cut
 105
 106 sub generated_file_header {
 107     my ( $filename, $style ) = @_;
 108
 109     die qq{unknown style "$style"}
 110         if $style !~ m/\A(?:perl|c)\z/;
 111
 112     require File::Spec;
 113     my $script = File::Spec->abs2rel($0);
 114     $script =~ s/\\/\//g;
 115
 116     my $header = <<"END_HEADER";
 117 /* ex: set ro ft=c:
 118  * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 119  *
 120  * This file is generated automatically from '$filename'
 121  * by $script.
 122  *
 123  * Any changes made here will be lost!
 124  *
 125  */
 126 END_HEADER
 127
 128     if ( $style eq 'perl' ) {
 129         $header =~ s/^\/\*(.*?)ft=c:/# $1ft=perl:/;
 130         $header =~ s/\n \*\n \*\///;
 131         $header =~ s/^ \* ?/#  /msg;
 132     }
 133
 134     return $header;
 135 }
 136
 137 =item C<get_bc_version()>
 138
 139 Return an array of ($bc_major, $bc_minor) from F<PBC_COMPAT>.
 140 This is used in the native_pbc tests.
 141
 142 See also F<tools/dev/pbc_header.pl> and F<tools/build/pbcversion_h.pl>.
 143
 144 =cut
 145
 146 sub get_bc_version {
 147     my $compat_file = 'PBC_COMPAT';
 148     my ( $bc_major, $bc_minor );
 149     open my $IN, '<', $compat_file or die "Can't read $compat_file";
 150     while (<$IN>) {
 151         if (/^(\d+)\.0*(\d+)/) {
 152             ( $bc_major, $bc_minor ) = ( $1, $2 );
 153             last;
 154         }
 155     }
 156     unless ( defined $bc_major ) {
 157         die "No bytecode version found in '$compat_file'.";
 158     }
 159     close $IN;
 160     return ( $bc_major, $bc_minor );
 161 }
 162
 163 1;
 164
 165 =back
 166
 167 =cut
 168
 169 # Local Variables:
 170 #   mode: cperl
 171 #   cperl-indent-level: 4
 172 #   fill-column: 100
 173 # End:
 174 # vim: expandtab shiftwidth=4: