| 1 | # -*- perl -*- |
| 2 | |
| 3 | package Midas::Setup; |
| 4 | use strict; |
| 5 | use warnings; |
| 6 | |
| 7 | use IO::File; |
| 8 | |
| 9 | use Midas::Command; |
| 10 | use Midas::Paths; |
| 11 | use Midas::Section; |
| 12 | use Midas::MMU; |
| 13 | use Midas::Configure; |
| 14 | use Midas::State; |
| 15 | use Midas::Globals; |
| 16 | use Midas::Error; |
| 17 | |
| 18 | require Exporter; |
| 19 | |
| 20 | our @ISA = qw(Exporter); |
| 21 | our @EXPORT = qw(setup_files); |
| 22 | our @EXPORT_OK = qw(); |
| 23 | our %EXPORT_TAGS = ( |
| 24 | all => [qw( |
| 25 | setup_files |
| 26 | bring_local |
| 27 | split_perl_assembly |
| 28 | ), |
| 29 | ], |
| 30 | internals => [qw( |
| 31 | ), |
| 32 | ], |
| 33 | ); |
| 34 | |
| 35 | Exporter::export_ok_tags('all'); |
| 36 | |
| 37 | ############################################################################## |
| 38 | |
| 39 | # SETUP SECTION |
| 40 | # |
| 41 | # These functions prepare a diag for further processing. The external |
| 42 | # interface is the setup_files) function. |
| 43 | |
| 44 | ############################################################################## |
| 45 | |
| 46 | # setup_files($diag) - Exported function |
| 47 | |
| 48 | # Prepares a diag for processing: |
| 49 | # |
| 50 | # 1. If $STATE is undefined, create a new Midas::State object |
| 51 | # 2. Create build directory if it doesn't already exist |
| 52 | # 3. cd into build directory |
| 53 | # 4. Copy diag from specified path to build directory (default name |
| 54 | # is diag.src). |
| 55 | # 5. Split diag.src into perl and assembly parts |
| 56 | # |
| 57 | # Return value is the Midas::State object used. The function also has |
| 58 | # the side effect of changing the working directory to the build directory. |
| 59 | |
| 60 | |
| 61 | ############################################################################## |
| 62 | |
| 63 | sub setup_files { |
| 64 | my $diag_path = shift; |
| 65 | |
| 66 | banner "SETUP PHASE"; |
| 67 | |
| 68 | chat "### Will build in directory \"" . |
| 69 | $STATE->get_build_dir('-abs') . |
| 70 | "\"\n"; |
| 71 | |
| 72 | bring_local($diag_path); |
| 73 | |
| 74 | cd $STATE->get_build_dir(); |
| 75 | |
| 76 | my $pushd = Midas::Paths->pushd($STATE->get_build_dir()); |
| 77 | |
| 78 | split_perl_assembly(); |
| 79 | |
| 80 | } |
| 81 | |
| 82 | ############################################################################## |
| 83 | |
| 84 | # build_local($diag) |
| 85 | # |
| 86 | # Creates build_directory if it doesn't already exist. |
| 87 | # Copies $diag into build_directory. |
| 88 | # If the diag is a .pal diag, it runs PAL to convert it. |
| 89 | |
| 90 | ############################################################################## |
| 91 | |
| 92 | sub bring_local { |
| 93 | my $diag_path = shift; |
| 94 | |
| 95 | my $build_dir = $STATE->get_build_dir('-abs'); |
| 96 | |
| 97 | my $src = path_to_build_file($CONFIG{local_src}, $STATE); |
| 98 | if(not -d $build_dir) { |
| 99 | run_command("mkdir $build_dir", -errcode => M_DIR); |
| 100 | $STATE->set_created_build_dir(1); |
| 101 | } else { |
| 102 | my @intermed_files = map { path_to_build_file(exists $CONFIG{$_} ? |
| 103 | $CONFIG{$_} : $_, $STATE) } |
| 104 | @{$CONFIG{intermed_files}}; |
| 105 | |
| 106 | my $files_str = join ' ', @intermed_files; |
| 107 | run_command("rm -f $files_str", -errcode => M_FILE) if @intermed_files; |
| 108 | } |
| 109 | |
| 110 | if($diag_path =~ /\.pal$/) { |
| 111 | my $pal_opt = join ' ', @{$CONFIG{pal_opt}}; |
| 112 | $pal_opt .= ' ' if length $pal_opt; |
| 113 | my $pal_diag_args = join ' ', @{$CONFIG{pal_diag_args}}; |
| 114 | run_command("$CONFIG{pal_cmd} $pal_opt$diag_path $pal_diag_args > $src"); |
| 115 | } else { |
| 116 | run_command("cp $diag_path $src", -errcode => M_FILE); |
| 117 | } |
| 118 | run_command("chmod ug+w $src", -verbose => 3, -errcode => M_FILE); |
| 119 | } |
| 120 | |
| 121 | ############################################################################## |
| 122 | |
| 123 | # split_perl_assembly() |
| 124 | # |
| 125 | # Splits the diag.src into diag.s and diag.pl (of course, default names |
| 126 | # can be changed in Configure). Everything in diag.src before __PERL__ goes |
| 127 | # in diag.s. Everything after goes in diag.pl |
| 128 | |
| 129 | ############################################################################## |
| 130 | |
| 131 | sub split_perl_assembly { |
| 132 | my $src = path_to_build_file($CONFIG{local_src}, $STATE); |
| 133 | my $s = path_to_build_file($CONFIG{local_s}, $STATE); |
| 134 | my $pl = path_to_build_file($CONFIG{local_pl}, $STATE); |
| 135 | |
| 136 | my $src_fh = IO::File->new("<$src") or fatal "Can't open $src: $!\n", M_FILE; |
| 137 | my $s_fh = IO::File->new(">$s") or fatal "Can't open $s: $!\n", M_FILE; |
| 138 | my $pl_fh; |
| 139 | |
| 140 | chat "Splitting $src into $s and $pl (if necessary).\n"; |
| 141 | |
| 142 | while(<$src_fh>) { |
| 143 | |
| 144 | if(defined $pl_fh) { |
| 145 | $pl_fh->print($_); |
| 146 | } elsif(/^\s*__PERL__/) { |
| 147 | chat "$src conitains perl code, so creating $pl\n", 2; |
| 148 | $pl_fh = IO::File->new(">$pl") or fatal "Can't open $pl: $!\n", M_FILE; |
| 149 | } else { |
| 150 | $s_fh->print($_); |
| 151 | } |
| 152 | |
| 153 | } |
| 154 | # just in case the user didn't end with a newline |
| 155 | $s_fh->print("\n"); |
| 156 | $pl_fh->print("\n") if defined $pl_fh; |
| 157 | |
| 158 | undef $src_fh; |
| 159 | undef $s_fh; |
| 160 | undef $pl_fh; |
| 161 | } |
| 162 | |
| 163 | ############################################################################## |
| 164 | 1; |