Commit | Line | Data |
---|---|---|
86530b38 AT |
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; |