/modules/TemplateParser.pm
Perl | 2354 lines | 1854 code | 321 blank | 179 comment | 274 complexity | 9cd18341dfca18a174fec189608e3fa5 MD5 | raw file
- package TemplateParser;
- # ************************************************************
- # Description : Parses the template and fills in missing values
- # Author : Chad Elliott
- # Create Date : 5/17/2002
- # $Id$
- # ************************************************************
- # ************************************************************
- # Pragmas
- # ************************************************************
- use strict;
- use File::Path;
- use Parser;
- use WinVersionTranslator;
- use vars qw(@ISA);
- @ISA = qw(Parser);
- # ************************************************************
- # Data Section
- # ************************************************************
- # Valid keywords for use in template files. Each has a handle_
- # method available, but some have other methods too.
- # Bit Meaning
- # 0 means there is a get_ method available (used by if and nested functions)
- # 1 means there is a perform_ method available (used by foreach and nested)
- # 2 means there is a doif_ method available (used by if)
- # 3 means that parameters to perform_ should not be evaluated
- # 4 means there is a post_ method available (called after the results of
- # calling perform_ for a nested function are written to the output)
- # 5 means that the get_ method performs the get_ and doif_ functionality
- #
- # Perl Function Parameter Type Return Type
- # get_ string string or array
- # perform_ array reference array
- # doif_ array reference boolean
- #
- my $get_type = 1 << 0;
- my $perform_type = 1 << 1;
- my $doif_type = 1 << 2;
- my $perform_no_eval_type = 1 << 3;
- my $post_type = 1 << 4;
- my $get_combined_type = 1 << 5;
- my %keywords = ('if' => 0,
- 'else' => 0,
- 'endif' => 0,
- 'noextension' => $get_type|$perform_type,
- 'dirname' => $get_type|$perform_type|$doif_type,
- 'basename' => $get_type|$perform_type|$doif_type,
- 'basenoextension' => 0,
- 'foreach' => 0,
- 'forfirst' => 0,
- 'fornotfirst' => 0,
- 'fornotlast' => 0,
- 'forlast' => 0,
- 'endfor' => 0,
- 'eval' => 0,
- 'comment' => 0,
- 'marker' => 0,
- 'uc' => $get_type|$perform_type,
- 'lc' => $get_type|$perform_type,
- 'ucw' => 0,
- 'normalize' => $get_type|$perform_type,
- 'flag_overrides' => $get_type,
- 'reverse' => $get_type|$perform_type,
- 'sort' => $get_type|$perform_type,
- 'uniq' => $get_type|$perform_type,
- 'multiple' => $get_type|$doif_type|$get_combined_type,
- 'starts_with' => $get_type|$doif_type|$get_combined_type,
- 'ends_with' => $get_type|$doif_type|$get_combined_type,
- 'contains' => $get_type|$doif_type|$get_combined_type,
- 'subst' => $get_type|$doif_type|$get_combined_type,
- 'remove_from' => $get_type|$perform_type|$doif_type|$perform_no_eval_type|$get_combined_type,
- 'compares' => $get_type|$doif_type|$get_combined_type,
- 'vars_equal' => $get_type|$perform_type,
- 'duplicate_index' => $get_type|$doif_type|$get_combined_type,
- 'transdir' => $get_type|$doif_type,
- 'has_extension' => $get_type|$doif_type|$get_combined_type,
- 'keyname_used' => 0,
- 'scope' => 0,
- 'full_path' => $get_type|$perform_type,
- 'extensions' => $perform_type|$perform_no_eval_type,
- 'create_aux_file' => $perform_type|$post_type,
- 'end_aux_file' => 0,
- 'translate_vars' => $get_type|$perform_type,
- 'convert_slashes' => $perform_type,
- 'new_guid' => 0,
- 'deref' => 0,
- 'set' => 0,
- );
- my %target_type_vars = ('type_is_static' => 1,
- 'need_staticflags' => 1,
- 'type_is_dynamic' => 1,
- 'type_is_binary' => 1,
- );
- my %arrow_op_ref = ('custom_type' => 'custom types',
- 'grouped_.*_file' => 'grouped files',
- 'feature' => 'features',
- );
- # optmized regex
- my $parse_line_re1 = qr/^[ ]*<%(\w+)(?:\((?:(?:\w+\s*,\s*)*[!]?\w+\(.+\)|[^\)]+)\))?%>$/;
- my $process_name_re1 = qr/([^%\(]+)(\(([^%]+)\))?%>/;
- # ************************************************************
- # Subroutine Section
- # ************************************************************
- sub new {
- my($class, $prjc) = @_;
- my $self = $class->SUPER::new();
- $self->{'prjc'} = $prjc;
- $self->{'ti'} = $prjc->get_template_input();
- $self->{'cslashes'} = $prjc->convert_slashes();
- $self->{'crlf'} = $prjc->crlf();
- $self->{'cmds'} = $prjc->get_command_subs();
- $self->{'vnames'} = $prjc->get_valid_names();
- $self->{'values'} = {};
- $self->{'defaults'} = {};
- $self->{'lines'} = [];
- $self->{'built'} = '';
- $self->{'sstack'} = [];
- $self->{'lstack'} = [];
- $self->{'if_skip'} = 0;
- $self->{'eval'} = 0;
- $self->{'eval_str'} = '';
- $self->{'dupfiles'} = {};
- $self->{'override_target_type'} = undef;
- $self->{'keyname_used'} = {};
- $self->{'scopes'} = {};
- $self->{'aux_file'} = undef;
- $self->{'foreach'} = {};
- $self->{'foreach'}->{'count'} = -1;
- $self->{'foreach'}->{'nested'} = 0;
- $self->{'foreach'}->{'name'} = [];
- $self->{'foreach'}->{'vars'} = [];
- $self->{'foreach'}->{'text'} = [];
- $self->{'foreach'}->{'scope'} = [];
- $self->{'foreach'}->{'scope_name'} = [];
- $self->{'foreach'}->{'temp_scope'} = [];
- $self->{'foreach'}->{'processing'} = 0;
- return $self;
- }
- sub tp_basename {
- my($self, $file) = @_;
- if ($self->{'cslashes'}) {
- $file =~ s/.*[\/\\]//;
- }
- else {
- $file =~ s/.*\///;
- }
- return $file;
- }
- sub validated_dirname {
- my($self, $file) = @_;
- my $index = rindex($file, ($self->{'cslashes'} ? '\\' : '/'));
- if ($index >= 0) {
- return $self->{'prjc'}->validated_directory(substr($file, 0, $index));
- }
- else {
- return '.';
- }
- }
- sub tp_dirname {
- my($self, $file) = @_;
- my $index = rindex($file, ($self->{'cslashes'} ? '\\' : '/'));
- if ($index >= 0) {
- return substr($file, 0, $index);
- }
- else {
- return '.';
- }
- }
- sub strip_line {
- #my $self = shift;
- #my $line = shift;
- ## Override strip_line() from Parser.
- ## We need to preserve leading space and
- ## there is no comment string in templates.
- ++$_[0]->{'line_number'};
- $_[1] =~ s/\s+$//;
- return $_[1];
- }
- ## Append the current value to the line that is being
- ## built. This line may be a foreach line or a general
- ## line without a foreach.
- sub append_current {
- my $value = $_[1];
- my $scope = $_[0]->{'scopes'};
- while(defined $$scope{'scope'}) {
- $scope = $$scope{'scope'};
- if (defined $$scope{'escape'}) {
- if ($$scope{'escape'}->[1] < 0 && $_[0]->{'foreach'}->{'count'} >= 0) {
- ## This scope was created outside of a foreach. If we are
- ## processing a foreach, we need to skip this at this point as it
- ## will be handled once the foreach has been completed and is
- ## appended to the main project body.
- last;
- }
- else {
- my $key = $$scope{'escape'}->[0];
- if ($key eq '\\') {
- $value =~ s/\\/\\\\/g;
- }
- else {
- $value =~ s/($key)/\\$1/g;
- }
- }
- }
- else {
- foreach my $key (keys %$scope) {
- $_[0]->warning("Unrecognized scope function: $key.");
- }
- }
- }
- my $foreach_count = $_[0]->{'foreach'}->{'count'};
- if ($_[0]->{'aux_file'}
- && $foreach_count == $_[0]->{'aux_file'}->{'foreach_baseline'}) {
- $_[0]->{'aux_file'}->{'text'} .= $value;
- }
- elsif ($foreach_count >= 0) {
- $_[0]->{'foreach'}->{'text'}->[$foreach_count] .= $value;
- }
- elsif ($_[0]->{'eval'}) {
- $_[0]->{'eval_str'} .= $value;
- }
- else {
- $_[0]->{'built'} .= $value;
- }
- }
- sub split_parameters {
- my($self, $str) = @_;
- my @params;
- while($str =~ /^(\w+\([^\)]+\))(.*)/ || $str =~ /^([^,]+)(.*)/) {
- push(@params, $1);
- $str = $2;
- $str =~ s/^\s*,\s*//;
- }
- ## Return the parameters (which includes whatever is left in the
- ## string). Just return it instead of pushing it onto @params.
- return $str eq '' ? @params : (@params, $str);
- }
- sub set_current_values {
- my($self, $name) = @_;
- my $set = 0;
- ## If any value within a foreach matches the name
- ## of a hash table within the template input we will
- ## set the values of that hash table in the current scope
- if (defined $self->{'ti'}) {
- my $counter = $self->{'foreach'}->{'count'};
- if ($counter >= 0) {
- ## Variable names are case-insensitive in MPC, however this can
- ## cause problems when dealing with template variable values that
- ## happen to match HASH names only by case-insensitivity. So, we
- ## now make HASH names match with case-sensitivity.
- my $value = $self->{'ti'}->get_value($name);
- if (defined $value && UNIVERSAL::isa($value, 'HASH') &&
- $self->{'ti'}->get_realname($name) eq $name) {
- $self->{'foreach'}->{'scope_name'}->[$counter] = $name;
- my %copy;
- foreach my $key (keys %$value) {
- $copy{$key} = $self->{'prjc'}->adjust_value(
- [$name . '::' . $key, $name], $$value{$key}, $self);
- }
- $self->{'foreach'}->{'temp_scope'}->[$counter] = \%copy;
- $set = 1;
- }
- else {
- ## Since we're not creating a temporary scope for this level, we
- ## need to empty out the scope that may have been held here from
- ## a previous foreach.
- $self->{'foreach'}->{'temp_scope'}->[$counter] = {};
- }
- }
- }
- return $set;
- }
- sub get_value {
- my($self, $name) = @_;
- my $value;
- my $counter = $self->{'foreach'}->{'count'};
- my $fromprj;
- my @scopes;
- my @snames;
- my $adjust = 1;
- ## $name should always be all lower-case
- $name = lc($name);
- ## First, check the temporary scope (set inside a foreach)
- if ($counter >= 0) {
- ## Create a list of possible scoped names
- @scopes = reverse @{$self->{'foreach'}->{'scope_name'}};
- @snames = map { defined $_ ? $_ . '::' . $name : $name } @scopes;
- push(@snames, $name);
- while(!defined $value && $counter >= 0) {
- $value = $self->{'foreach'}->{'temp_scope'}->[$counter]->{$name};
- --$counter;
- }
- $counter = $self->{'foreach'}->{'count'};
- if ($self->{'override_target_type'} &&
- defined $value && defined $target_type_vars{$name}) {
- $value = $self->{'values'}->{$name};
- }
- }
- else {
- @snames = ($name);
- }
- if (!defined $value) {
- if ($name =~ /^flag_overrides\((.*)\)$/) {
- $value = $self->get_flag_overrides($1);
- }
- if (!defined $value) {
- ## Next, check for a template value
- if (defined $self->{'ti'}) {
- $value = $self->{'ti'}->get_value($name);
- }
- if (!defined $value) {
- ## Calling adjust_value here allows us to pick up template
- ## overrides before getting values elsewhere.
- my $uvalue = $self->{'prjc'}->adjust_value(\@snames, [], $self);
- if (defined $$uvalue[0]) {
- $value = $uvalue;
- $adjust = 0;
- $fromprj = 1;
- }
- if (!defined $value) {
- ## Next, check the inner to outer foreach
- ## scopes for overriding values
- while(!defined $value && $counter >= 0) {
- $value = $self->{'foreach'}->{'scope'}->[$counter]->{$name};
- --$counter;
- }
- ## Then get the value from the project creator
- if (!defined $value) {
- $fromprj = 1;
- $value = $self->{'prjc'}->get_assignment($name);
- ## Then get it from our known values
- if (!defined $value) {
- $value = $self->{'values'}->{$name};
- if (!defined $value) {
- ## Call back onto the project creator to allow
- ## it to fill in the value before defaulting to undef.
- $value = $self->{'prjc'}->fill_value($name);
- if (!defined $value && $name =~ /^(.*)\->(\w+)/) {
- my $pre = $1;
- my $post = $2;
- my $base = $self->get_value($pre);
- if (defined $base) {
- $value = $self->{'prjc'}->get_special_value(
- $pre, $post, $base,
- ($self->{'prjc'}->requires_parameters($post) ?
- $self->prepare_parameters($pre) : undef));
- }
- }
- }
- }
- }
- }
- }
- }
- }
- ## Adjust the value even if we haven't obtained one from an outside
- ## source.
- if ($adjust && defined $value) {
- $value = $self->{'prjc'}->adjust_value(\@snames, $value, $self);
- }
- ## If the value did not come from the project creator, we
- ## check the variable name. If it is a project keyword we then
- ## check to see if we need to add the project value to the template
- ## variable value. If so, we make a copy of the value array and
- ## push the project value onto that (to avoid modifying the original).
- if (!$fromprj && defined $self->{'vnames'}->{$name} &&
- $self->{'prjc'}->add_to_template_input_value($name)) {
- my $pjval = $self->{'prjc'}->get_assignment($name);
- if (defined $pjval) {
- my @copy = @$value;
- if (!UNIVERSAL::isa($pjval, 'ARRAY')) {
- $pjval = $self->create_array($pjval);
- }
- push(@copy, @$pjval);
- $value = \@copy;
- }
- }
- return (defined $value ?
- $self->{'prjc'}->relative($value, undef, \@scopes) : undef);
- }
- sub get_value_with_default {
- my $self = shift;
- my $name = lc(shift);
- my $value = $self->get_value($name);
- if (!defined $value) {
- $value = $self->{'defaults'}->{$name};
- if (defined $value) {
- my $counter = $self->{'foreach'}->{'count'};
- my $sname;
- if ($counter >= 0) {
- ## Find the outer most scope for our variable name
- for(my $index = $counter; $index >= 0; --$index) {
- if (defined $self->{'foreach'}->{'scope_name'}->[$index]) {
- $sname = $self->{'foreach'}->{'scope_name'}->[$index] .
- '::' . $name;
- last;
- }
- }
- }
- $value = $self->{'prjc'}->relative(
- $self->{'prjc'}->adjust_value(
- [$sname, $name], $value, $self));
- ## If the user set the variable to empty, we will go ahead and use
- ## the default value (since we know we have one at this point).
- $value = $self->{'defaults'}->{$name} if (!defined $value);
- }
- else {
- #$self->warning("$name defaulting to empty string.");
- $value = '';
- }
- }
- return (UNIVERSAL::isa($value, 'ARRAY') ? "@$value" : $value);
- }
- sub process_foreach {
- my $self = shift;
- my $index = $self->{'foreach'}->{'count'};
- my $text = $self->{'foreach'}->{'text'}->[$index];
- my @values;
- my $name = $self->{'foreach'}->{'name'}->[$index];
- my @cmds;
- my $val = $self->{'foreach'}->{'vars'}->[$index];
- my $check_for_mixed;
- if ($val =~ /^((\w+),\s*)?flag_overrides\((.*)\)$/) {
- ## If the user did not provide a name we have to pick one otherwise
- ## there would be no way to access the foreach values.
- $name = (defined $2 ? $2 : '__unnamed__');
- ## Now check to see if there were overrides for this value. If there
- ## were, convert them into an array (if necessary) and continue
- ## processing.
- $val = $self->get_flag_overrides($3);
- if (defined $val) {
- $val = $self->create_array($val) if (!UNIVERSAL::isa($val, 'ARRAY'));
- @values = @$val;
- }
- }
- else {
- ## Pull out modifying commands first
- while($val =~ /(\w+)\((.+)\)/) {
- my $cmd = $1;
- $val = $2;
- if (($keywords{$cmd} & $perform_type) != 0) {
- push(@cmds, 'perform_' . $cmd);
- if (($keywords{$cmd} & $perform_no_eval_type) != 0) {
- my @params = $self->split_parameters($val);
- $val = \@params;
- last;
- }
- }
- else {
- $self->warning("Unable to use $cmd in foreach (no perform_ method).");
- }
- }
- ## Get the values for all of the variable names
- ## contained within the foreach
- if (UNIVERSAL::isa($val, 'ARRAY')) {
- @values = @$val;
- }
- else {
- my $names = $self->create_array($val);
- foreach my $n (@$names) {
- my $vals = $self->get_value($n);
- if (defined $vals && $vals ne '') {
- if (!UNIVERSAL::isa($vals, 'ARRAY')) {
- $vals = $self->create_array($vals);
- }
- push(@values, @$vals);
- }
- if (!defined $name) {
- $name = $n;
- $name =~ s/s$//;
- }
- ## We only want to check for the mixing of scalar and hash
- ## variables if the variable name is not a keyword (or the
- ## special 'features' template variable).
- if (!$check_for_mixed &&
- !$self->{'prjc'}->is_keyword($n) && $n ne 'features') {
- $check_for_mixed = 1;
- }
- }
- }
- }
- ## Perform the commands on the built up @values
- foreach my $cmd (reverse @cmds) {
- @values = $self->$cmd(\@values);
- }
- ## Reset the text (it will be regenerated by calling parse_line
- $self->{'foreach'}->{'text'}->[$index] = '';
- if (defined $values[0]) {
- my $scope = $self->{'foreach'}->{'scope'}->[$index];
- my $base = $self->{'foreach'}->{'base'}->[$index];
- $$scope{'forlast'} = '';
- $$scope{'fornotlast'} = 1;
- $$scope{'forfirst'} = 1;
- $$scope{'fornotfirst'} = '';
- ## If the foreach values are mixed (HASH and SCALAR), then
- ## remove the SCALAR values.
- if ($check_for_mixed) {
- my %mixed;
- my $mixed = 0;
- foreach my $mval (@values) {
- $mixed{$mval} = $self->set_current_values($mval);
- $mixed |= $mixed{$mval};
- }
- if ($mixed) {
- my @nvalues;
- foreach my $key (sort keys %mixed) {
- push(@nvalues, $key) if ($mixed{$key});
- }
- ## Set the new values only if they are different
- ## from the original (except for order).
- my @sorted = sort(@values);
- @values = @nvalues if (@sorted != @nvalues);
- }
- }
- for(my $i = 0; $i <= $#values; ++$i) {
- my $value = $values[$i];
- ## Set the corresponding values in the temporary scope
- $self->set_current_values($value);
- ## Set the special values that only exist
- ## within a foreach
- if ($i != 0) {
- $$scope{'forfirst'} = '';
- $$scope{'fornotfirst'} = 1;
- }
- if ($i == $#values) {
- $$scope{'forlast'} = 1;
- $$scope{'fornotlast'} = '';
- }
- $$scope{'forcount'} = $i + $base;
- ## We don't use adjust_value here because these names
- ## are generated from a foreach and should not be adjusted.
- $$scope{$name} = $value;
- ## A tiny hack for VC7
- if ($name eq 'configuration' &&
- $self->get_value_with_default('platform') ne '') {
- $self->{'prjc'}->update_project_info($self, 1,
- ['configuration', 'platform'],
- '|');
- }
- ## Now parse the line of text, each time
- ## with different values
- ++$self->{'foreach'}->{'processing'};
- my($status, $error) = $self->parse_line(undef, $text);
- --$self->{'foreach'}->{'processing'};
- return $error if (defined $error);
- }
- }
- return undef;
- }
- sub generic_handle {
- my($self, $func, $str) = @_;
- if (defined $str) {
- my $val = $self->$func([$str]);
- if (defined $val) {
- $self->append_current($val);
- }
- else {
- $self->append_current(0);
- }
- }
- }
- sub handle_endif {
- my($self, $name) = @_;
- my $end = pop(@{$self->{'sstack'}});
- pop(@{$self->{'lstack'}});
- if (!defined $end) {
- return "Unmatched $name";
- }
- else {
- my $in = index($end, $name);
- if ($in == 0) {
- $self->{'if_skip'} = 0;
- }
- elsif ($in == -1) {
- return "Unmatched $name";
- }
- }
- return undef;
- }
- sub handle_endfor {
- my($self, $name) = @_;
- my $end = pop(@{$self->{'sstack'}});
- pop(@{$self->{'lstack'}});
- if (!defined $end) {
- return "Unmatched $name";
- }
- else {
- my $in = index($end, $name);
- if ($in == 0) {
- my $index = $self->{'foreach'}->{'count'};
- my $error = $self->process_foreach();
- if (!defined $error) {
- --$self->{'foreach'}->{'count'};
- $self->append_current($self->{'foreach'}->{'text'}->[$index]);
- }
- return $error;
- }
- elsif ($in == -1) {
- return "Unmatched $name";
- }
- }
- return undef;
- }
- sub get_flag_overrides {
- my($self, $name) = @_;
- my $type;
- ## Split the name and type parameters
- ($name, $type) = split(/,\s*/, $name);
- my $file = $self->get_value($name);
- if (defined $file) {
- ## Save the name prefix (if there is one) for
- ## command parameter conversion at the end
- my $pre;
- if ($name =~ /^(\w+)->/) {
- $pre = $1;
- ## Replace the custom_type key with the actual custom type
- if ($pre eq 'custom_type') {
- my $ct = $self->get_value($pre);
- $name = $ct if (defined $ct);
- }
- elsif ($pre =~ /^grouped_(.*_file)$/) {
- $name = $1;
- }
- }
- my $fo = $self->{'prjc'}->{'flag_overrides'};
- my $key = (defined $$fo{$name . 's'} ? $name . 's' :
- (defined $$fo{$name} ? $name : undef));
- if (defined $key) {
- ## Convert the file name into a unix style file name
- my $ustyle = $file;
- $ustyle =~ s/\\/\//g if ($self->{'cslashes'});
- ## Save the directory portion for checking in the foreach
- my $dir = $self->mpc_dirname($ustyle);
- my $of = (defined $$fo{$key}->{$ustyle} ? $ustyle :
- (defined $$fo{$key}->{$dir} ? $dir : undef));
- if (defined $of) {
- my $prjc = $self->{'prjc'};
- foreach my $aname (@{$prjc->{'matching_assignments'}->{$key}}) {
- if ($aname eq $type && defined $$fo{$key}->{$of}->{$aname}) {
- my $value = $$fo{$key}->{$of}->{$aname};
- ## If the name that we're overriding has a value and
- ## requires parameters, then we will convert all of the
- ## pseudo variables and provide parameters.
- if (defined $pre && $prjc->requires_parameters($type)) {
- $value = $prjc->convert_command_parameters(
- $key, $value,
- $self->prepare_parameters($pre));
- }
- return $prjc->relative($value);
- }
- }
- }
- }
- }
- return undef;
- }
- sub get_multiple {
- my($self, $name) = @_;
- return $self->doif_multiple(
- $self->create_array($self->get_value_with_default($name)));
- }
- sub doif_multiple {
- my($self, $value) = @_;
- return defined $value ? (scalar(@$value) > 1) : undef;
- }
- sub handle_multiple {
- my($self, $name) = @_;
- my $val = $self->get_value_with_default($name);
- if (defined $val) {
- my $array = $self->create_array($val);
- $self->append_current(scalar(@$array));
- }
- else {
- $self->append_current(0);
- }
- }
- sub get_starts_with {
- my($self, $str) = @_;
- return $self->doif_starts_with([$str]);
- }
- sub doif_starts_with {
- my($self, $val) = @_;
- if (defined $val) {
- my($name, $pattern) = $self->split_parameters("@$val");
- if (defined $name && defined $pattern) {
- return ($self->get_value_with_default($name) =~ /^$pattern/);
- }
- }
- return undef;
- }
- sub handle_starts_with {
- my($self, $str) = @_;
- $self->generic_handle('doif_starts_with', $str);
- }
- sub get_ends_with {
- my($self, $str) = @_;
- return $self->doif_ends_with([$str]);
- }
- sub doif_ends_with {
- my($self, $val) = @_;
- if (defined $val) {
- my($name, $pattern) = $self->split_parameters("@$val");
- if (defined $name && defined $pattern) {
- return ($self->get_value_with_default($name) =~ /$pattern$/);
- }
- }
- return undef;
- }
- sub handle_ends_with {
- my($self, $str) = @_;
- $self->generic_handle('doif_ends_with', $str);
- }
- sub handle_keyname_used {
- my($self, $str) = @_;
- if (defined $str) {
- my($name, $key) = $self->split_parameters($str);
- my $file = $self->get_value_with_default($name);
- if (defined $self->{'keyname_used'}->{$file}->{$key}) {
- $self->append_current($self->{'keyname_used'}->{$file}->{$key}++);
- }
- else {
- $self->{'keyname_used'}->{$file}->{$key} = 1;
- }
- }
- }
- sub handle_scope {
- my($self, $str) = @_;
- if (defined $str) {
- my($state, $func, $param) = $self->split_parameters($str);
- if (defined $state) {
- my $pscope;
- my $scope = $self->{'scopes'};
- while(defined $$scope{'scope'}) {
- $pscope = $scope;
- $scope = $$scope{'scope'};
- }
- if ($state eq 'enter') {
- if (defined $func) {
- $param = '' if (!defined $param);
- $$scope{'scope'}->{$func} = [$self->process_special($param),
- $_[0]->{'foreach'}->{'count'}];
- }
- else {
- $self->warning("The enter scope function requires a parameter.");
- }
- }
- elsif ($state eq 'leave') {
- if (defined $pscope) {
- delete $$pscope{'scope'};
- }
- else {
- $self->warning("leave scope function encountered without an enter.");
- }
- }
- else {
- $self->warning("Unrecognized scope function parameter: $state.");
- }
- }
- else {
- $self->warning("The scope function requires 1 to 3 parameters.");
- }
- }
- }
- sub get_has_extension {
- my($self, $str) = @_;
- return $self->doif_has_extension([$str]);
- }
- sub doif_has_extension {
- my($self, $val) = @_;
- if (defined $val) {
- return ($self->tp_basename(
- $self->get_value_with_default("@$val")) =~ /\.[^\.]*$/);
- }
- return undef;
- }
- sub handle_has_extension {
- my($self, $str) = @_;
- $self->generic_handle('doif_has_extension', $str);
- }
- sub get_contains {
- my($self, $str) = @_;
- return $self->doif_contains([$str]);
- }
- sub doif_contains {
- my($self, $val) = @_;
- if (defined $val) {
- my($name, $pattern) = $self->split_parameters("@$val");
- if (defined $name && defined $pattern) {
- return ($self->get_value_with_default($name) =~ /$pattern/);
- }
- }
- return undef;
- }
- sub handle_contains {
- my($self, $str) = @_;
- $self->generic_handle('doif_contains', $str);
- }
- sub get_subst {
- my($self, $str) = @_;
- return $self->doif_subst([$str]);
- }
- sub doif_subst {
- my($self, $val) = @_;
- if (defined $val) {
- my($name, $pattern, $replacement) = $self->split_parameters("@$val");
- if (defined $name && defined $pattern && defined $replacement) {
- my $result = $self->get_value_with_default($name);
- $result =~ s/$pattern/$replacement/g;
- return $result;
- }
- }
- return undef;
- }
- sub handle_subst {
- my($self, $str) = @_;
- $self->generic_handle('doif_subst', $str);
- }
- sub get_remove_from {
- my($self, $str) = @_;
- return $self->doif_remove_from($str);
- }
- sub doif_remove_from {
- my($self, $str) = @_;
- my @params = $self->split_parameters($str);
- my @removed = $self->perform_remove_from(\@params);
- return (defined $removed[0] ? 1 : undef);
- }
- sub perform_remove_from {
- my($self, $val) = @_;
- my($source, $pattern, $target, $tremove) = @$val;
- ## $source should be a component name (e.g., source_files,
- ## header_files, etc.) $target is a variable name
- ## $pattern and $tremove are optional; $pattern is a partial regular
- ## expression to match the end of the files found from $source. The
- ## beginning of the regular expression is made from $target by removing
- ## $tremove from the end of it.
- if (defined $source && defined $target &&
- defined $self->{'values'}->{$source}) {
- my $tval = $self->get_value_with_default($target);
- if (defined $tval) {
- $tval =~ s/$tremove$// if (defined $tremove);
- $tval = $self->escape_regex_special($tval);
- my @removed;
- my $max = scalar(@{$self->{'values'}->{$source}});
- for(my $i = 0; $i < $max;) {
- if ($self->{'values'}->{$source}->[$i] =~ /^$tval$pattern$/) {
- push(@removed, splice(@{$self->{'values'}->{$source}}, $i, 1));
- $max--;
- }
- else {
- $i++;
- }
- }
- return @removed;
- }
- }
- return ();
- }
- sub handle_remove_from {
- my($self, $str) = @_;
- if (defined $str) {
- my @params = $self->split_parameters($str);
- my $val = $self->perform_remove_from(\@params);
- $self->append_current("@$val") if (defined $val);
- }
- }
- sub get_compares {
- my($self, $str) = @_;
- return $self->doif_compares([$str]);
- }
- sub doif_compares {
- my($self, $val) = @_;
- if (defined $val) {
- my($name, $pattern) = $self->split_parameters("@$val");
- if (defined $name && defined $pattern) {
- return ($self->get_value_with_default($name) eq $pattern);
- }
- }
- return undef;
- }
- sub handle_compares {
- my($self, $str) = @_;
- $self->generic_handle('doif_compares', $str);
- }
- sub get_vars_equal {
- my($self, $str) = @_;
- return $self->doif_vars_equal([$str]);
- }
- sub doif_vars_equal {
- my($self, $val) = @_;
- if (defined $val) {
- my($var1, $var2) = $self->split_parameters("@$val");
- if (defined $var1 && defined $var2) {
- return ($self->get_value_with_default($var1) eq $self->get_value_with_default($var2));
- }
- }
- return undef;
- }
- sub handle_vars_equal {
- my($self, $str) = @_;
- $self->generic_handle('doif_vars_equal', $str);
- }
- sub get_reverse {
- my($self, $name) = @_;
- my $value = $self->get_value_with_default($name);
- if (defined $value) {
- my @array = $self->perform_reverse($self->create_array($value));
- return \@array;
- }
- return undef;
- }
- sub perform_reverse {
- my($self, $value) = @_;
- return reverse(@$value);
- }
- sub handle_reverse {
- my($self, $name) = @_;
- my $val = $self->get_value_with_default($name);
- if (defined $val) {
- my @array = $self->perform_reverse($self->create_array($val));
- $self->append_current("@array");
- }
- }
- sub get_sort {
- my($self, $name) = @_;
- my $value = $self->get_value_with_default($name);
- if (defined $value) {
- my @array = $self->perform_sort($self->create_array($value));
- return \@array;
- }
- return undef;
- }
- sub perform_sort {
- my($self, $value) = @_;
- return sort(@$value);
- }
- sub handle_sort {
- my($self, $name) = @_;
- my $val = $self->get_value_with_default($name);
- if (defined $val) {
- my @array = $self->perform_sort($self->create_array($val));
- $self->append_current("@array");
- }
- }
- sub get_uniq {
- my($self, $name) = @_;
- my $value = $self->get_value_with_default($name);
- if (defined $value) {
- my @array = $self->perform_uniq($self->create_array($value));
- return \@array;
- }
- return undef;
- }
- sub perform_uniq {
- my($self, $value) = @_;
- my %value;
- @value{@$value} = ();
- return sort(keys %value);
- }
- sub handle_uniq {
- my($self, $name) = @_;
- my $val = $self->get_value_with_default($name);
- if (defined $val) {
- my @array = $self->perform_uniq($self->create_array($val));
- $self->append_current("@array");
- }
- }
- sub process_compound_if {
- my($self, $str) = @_;
- if (index($str, '||') >= 0) {
- my $ret = 0;
- foreach my $v (split(/\s*\|\|\s*/, $str)) {
- $ret |= $self->process_compound_if($v);
- return 1 if ($ret != 0);
- }
- return 0;
- }
- elsif (index($str, '&&') >= 0) {
- my $ret = 1;
- foreach my $v (split(/\s*\&\&\s*/, $str)) {
- $ret &&= $self->process_compound_if($v);
- return 0 if ($ret == 0);
- }
- return 1;
- }
- else {
- ## See if we need to reverse the return value
- my $not = 0;
- if ($str =~ /^!+(.*)/) {
- $not = 1;
- $str = $1;
- }
- ## Get the value based on the string
- my @cmds;
- my $val;
- while($str =~ /(\w+)\((.+)\)(.*)/) {
- if ($3 eq '') {
- push(@cmds, $1);
- $str = $2;
- }
- else {
- ## If there is something trailing the closing parenthesis then
- ## the whole thing is considered a parameter to the first
- ## function.
- last;
- }
- }
- if (defined $cmds[0]) {
- ## Start out calling get_xxx on the string
- my $type = $get_type;
- my $prefix = 'get_';
- $val = $str;
- ## If there is only one command, we have to add it to the list
- ## again so that we can get the variable value and then use
- ## the doif_ version to test it, unless the get_ function
- ## also performs the doif_ functionality.
- if ($#cmds == 0 && defined $keywords{$cmds[0]} &&
- ($keywords{$cmds[0]} & $doif_type) != 0 &&
- ($keywords{$cmds[0]} & $get_combined_type) == 0) {
- push(@cmds, $cmds[0]);
- }
- foreach my $cmd (reverse @cmds) {
- if (defined $keywords{$cmd} && ($keywords{$cmd} & $type) != 0) {
- my $func = "$prefix$cmd";
- $val = $self->$func($val);
- ## Now that we have a value, we need to switch over
- ## to calling doif_xxx
- $type = $doif_type;
- $prefix = 'doif_';
- }
- else {
- $self->warning("Unable to use $cmd in if (no $prefix method).");
- }
- }
- }
- else {
- $val = $self->get_value($str);
- }
- ## See if any portion of the value is defined and not empty
- my $ret = 0;
- if (defined $val) {
- if (UNIVERSAL::isa($val, 'ARRAY')) {
- foreach my $v (@$val) {
- if ($v ne '') {
- $ret = 1;
- last;
- }
- }
- }
- elsif ($val ne '') {
- $ret = 1;
- }
- }
- return ($not ? !$ret : $ret);
- }
- }
- sub handle_if {
- my($self, $val) = @_;
- my $name = 'endif';
- push(@{$self->{'lstack'}},
- "<%if($val)%> (" . $self->get_line_number() . '?)');
- if ($self->{'if_skip'}) {
- push(@{$self->{'sstack'}}, "*$name");
- }
- else {
- ## Determine if we are skipping the portion of this if statement
- ## $val will always be defined since we won't get into this method
- ## without properly parsing the if statement.
- $self->{'if_skip'} = !$self->process_compound_if($val);
- push(@{$self->{'sstack'}}, $name);
- }
- }
- sub handle_else {
- my $self = shift;
- my @scopy = @{$self->{'sstack'}};
- my $index = index($scopy[$#scopy], 'endif');
- if ($index >= 0) {
- if ($index == 0) {
- $self->{'if_skip'} ^= 1;
- }
- $self->{'sstack'}->[$#scopy] .= ':';
- }
- return 'Unmatched else' if (($self->{'sstack'}->[$#scopy] =~ tr/:/:/) > 1);
- return undef;
- }
- sub handle_foreach {
- my $self = shift;
- my $val = lc(shift);
- my $name = 'endfor';
- my $errorString;
- push(@{$self->{'lstack'}}, $self->get_line_number());
- if (!$self->{'if_skip'}) {
- my $base = 1;
- my $vname;
- if ($val =~ /flag_overrides\([^\)]+\)/) {
- }
- elsif ($val =~ /([^,]*),(.*)/) {
- $vname = $1;
- $val = $2;
- $vname =~ s/^\s+//;
- $vname =~ s/\s+$//;
- $val =~ s/^\s+//;
- $val =~ s/\s+$//;
- if ($vname eq '') {
- $errorString = 'The foreach variable name is not valid';
- }
- if ($val =~ /([^,]*),(.*)/) {
- $base = $1;
- $val = $2;
- $base =~ s/^\s+//;
- $base =~ s/\s+$//;
- $val =~ s/^\s+//;
- $val =~ s/\s+$//;
- if ($base !~ /^\d+$/) {
- $errorString = 'The forcount specified is not a valid number';
- }
- }
- elsif ($vname =~ /^\d+$/) {
- $base = $vname;
- $vname = undef;
- }
- ## Due to the way flag_overrides works, we can't allow
- ## the user to name the foreach variable when dealing
- ## with variables that can be used with the -> operator
- if (defined $vname) {
- foreach my $ref (keys %arrow_op_ref) {
- my $name_re = $ref . 's';
- if ($val =~ /^$ref\->/ || $val =~ /^$name_re$/) {
- $errorString = 'The foreach variable can not be ' .
- 'named when dealing with ' .
- $arrow_op_ref{$ref};
- }
- }
- }
- }
- push(@{$self->{'sstack'}}, $name);
- my $index = ++$self->{'foreach'}->{'count'};
- $self->{'foreach'}->{'base'}->[$index] = $base;
- $self->{'foreach'}->{'name'}->[$index] = $vname;
- $self->{'foreach'}->{'vars'}->[$index] = $val;
- $self->{'foreach'}->{'text'}->[$index] = '';
- $self->{'foreach'}->{'scope'}->[$index] = {};
- $self->{'foreach'}->{'scope_name'}->[$index] = undef;
- }
- else {
- push(@{$self->{'sstack'}}, "*$name");
- }
- return $errorString;
- }
- sub handle_special {
- my($self, $name, $val) = @_;
- ## If $name (fornotlast, forfirst, etc.) is set to 1
- ## Then we append the $val onto the current string that's
- ## being built.
- $self->append_current($val) if ($self->get_value($name));
- }
- sub get_uc {
- my($self, $name) = @_;
- return uc($self->get_value_with_default($name));
- }
- sub handle_uc {
- my($self, $name) = @_;
- $self->append_current($self->get_uc($name));
- }
- sub perform_uc {
- my($self, $value) = @_;
- my @val;
- foreach my $val (@$value) {
- push(@val, uc($val));
- }
- return @val;
- }
- sub get_lc {
- my($self, $name) = @_;
- return lc($self->get_value_with_default($name));
- }
- sub handle_lc {
- my($self, $name) = @_;
- $self->append_current($self->get_lc($name));
- }
- sub perform_lc {
- my($self, $value) = @_;
- my @val;
- foreach my $val (@$value) {
- push(@val, lc($val));
- }
- return @val;
- }
- sub handle_ucw {
- my($self, $name) = @_;
- my $val = $self->get_value_with_default($name);
- substr($val, 0, 1) = uc(substr($val, 0, 1));
- while($val =~ /[_\s]([a-z])/) {
- my $uc = uc($1);
- $val =~ s/[_\s][a-z]/ $uc/;
- }
- $self->append_current($val);
- }
- sub actual_normalize {
- $_[1] =~ tr/ \t\/\\\-$()./_/;
- return $_[1];
- }
- sub perform_normalize {
- my($self, $value) = @_;
- my @val;
- foreach my $val (@$value) {
- push(@val, $self->actual_normalize($val));
- }
- return @val;
- }
- sub get_normalize {
- my($self, $name) = @_;
- return $self->actual_normalize($self->get_value_with_default($name));
- }
- sub handle_normalize {
- my($self, $name) = @_;
- $self->append_current($self->get_normalize($name));
- }
- sub actual_noextension {
- $_[1] =~ s/\.[^\.]*$//;
- return $_[1];
- }
- sub perform_noextension {
- my($self, $value) = @_;
- my @val;
- foreach my $val (@$value) {
- push(@val, $self->actual_noextension($val));
- }
- return @val;
- }
- sub get_noextension {
- my($self, $name) = @_;
- return $self->actual_noextension($self->get_value_with_default($name));
- }
- sub handle_noextension {
- my($self, $name) = @_;
- $self->append_current($self->get_noextension($name));
- }
- sub perform_full_path {
- my($self, $value) = @_;
- my @val;
- foreach my $val (@$value) {
- push(@val, $self->actual_full_path($val));
- }
- return @val;
- }
- sub get_full_path {
- my($self, $name) = @_;
- return $self->actual_full_path($self->get_value_with_default($name));
- }
- sub actual_full_path {
- my($self, $value) = @_;
- ## Expand all defined env vars
- $value =~ s/\$\((\w+)\)/$ENV{$1} || '$(' . $1 . ')'/ge;
- ## If we expanded all env vars, get absolute path
- if ($value =~ /\$\(\w+\)/) {
- $self->{'error_in_handle'} = "<%full_path%> couldn't expand " .
- "environment variables in $value";
- return $value;
- }
- ## Always convert the slashes since they may be in the OS native
- ## format and we need them in UNIX format.
- $value =~ s/\\/\//g;
- my $dir = $self->mpc_dirname($value);
- if (-e $dir) {
- $dir = Cwd::abs_path($dir);
- }
- elsif ($self->{'prjc'}->path_is_relative($dir)) {
- ## If the directory is is not already an absolute path, then we will
- ## assume that the directory is relative to the current directory
- ## (which will be the location of the MPC file).
- $dir = $self->getcwd() . '/' . $dir;
- }
- ## Create the full path value and convert the slashes if necessary.
- $value = $dir . '/' . $self->mpc_basename($value);
- $value =~ s/\//\\/g if ($self->{'cslashes'});
- return $value;
- }
- sub handle_full_path {
- my($self, $name) = @_;
- my $val = $self->get_value_with_default($name);
- $self->append_current($self->actual_full_path($val));
- }
- sub perform_extensions {
- my($self, $value) = @_;
- my @val;
- foreach my $val (@$value) {
- push(@val, $self->{'prjc'}->get_component_extensions($val));
- }
- return @val;
- }
- sub handle_extensions {
- my($self, $name) = @_;
- my @val = $self->perform_extensions([$name]);
- $self->append_current("@val");
- }
- sub evaluate_nested_functions {
- my($self, $funcname, $args) = @_;
- my @params = $self->split_parameters($args);
- my @results;
- foreach my $param (@params) {
- my @cmds;
- my $val = $param;
- while($val =~ /(\w+)\((.+)\)/) {
- push(@cmds, $1);
- $val = $2;
- }
- if (scalar @cmds == 0) {
- push @results, $val;
- next;
- }
- my $type = $get_type;
- my $prefix = 'get_';
- foreach my $cmd (reverse @cmds) {
- if (defined $keywords{$cmd} && ($keywords{$cmd} & $type) != 0) {
- my $func = "$prefix$cmd";
- if ($type == $get_type) {
- $val = $self->$func($val);
- $val = [ $val ] if (!UNIVERSAL::isa($val, 'ARRAY'));
- ## Now that we have a value, we need to switch over
- ## to calling perform_xxx
- $type = $perform_type;
- $prefix = 'perform_';
- }
- else {
- my @array = $self->$func($val);
- $val = \@array;
- }
- }
- else {
- $self->warning("Unable to use $cmd in nested " .
- "functions (no $prefix method).");
- }
- }
- push @results, "@$val";
- }
- if (defined $keywords{$funcname} && ($keywords{$funcname} & $perform_type)) {
- my $func = 'perform_' . $funcname;
- my @array = $self->$func(\@results);
- $self->append_current("@array");
- if ($keywords{$funcname} & $post_type) {
- $func = 'post_' . $funcname;
- $self->$func();
- }
- }
- else {
- $self->warning("Unable to use $funcname in nested " .
- "functions (no perform_ method).");
- }
- }
- sub perform_dirname {
- my($self, $value) = @_;
- my @val;
- foreach my $val (@$value) {
- push(@val, $self->tp_dirname($val));
- }
- return @val;
- }
- sub get_dirname {
- my($self, $name) = @_;
- return $self->tp_dirname($self->get_value_with_default($name));
- }
- sub doif_dirname {
- my($self, $value) = @_;
- if (defined $value) {
- $value = $self->tp_dirname($value);
- return ($value ne '.');
- }
- return undef;
- }
- sub handle_dirname {
- my($self, $name) = @_;
- $self->append_current(
- $self->tp_dirname($self->get_value_with_default($name)));
- }
- sub perform_basename {
- my($self, $value) = @_;
- my @val;
- foreach my $val (@$value) {
- push(@val, $self->tp_basename($val));
- }
- return @val;
- }
- sub get_basename {
- my($self, $name) = @_;
- return $self->tp_basename($self->get_value_with_default($name));
- }
- sub doif_basename {
- my($self, $value) = @_;
- if (defined $value) {
- $value = $self->tp_basename($value);
- return ($value ne '.');
- }
- return undef;
- }
- sub handle_basename {
- my($self, $name) = @_;
- $self->append_current(
- $self->tp_basename($self->get_value_with_default($name)));
- }
- sub handle_basenoextension {
- my($self, $name) = @_;
- my $val = $self->tp_basename($self->get_value_with_default($name));
- $val =~ s/\.[^\.]*$//;
- $self->append_current($val);
- }
- sub handle_flag_overrides {
- my($self, $name) = @_;
- my $value = $self->get_flag_overrides($name);
- $self->append_current(UNIVERSAL::isa($value, 'ARRAY') ?
- "@$value" : $value) if (defined $value);
- }
- sub handle_marker {
- my($self, $name) = @_;
- my $val = $self->{'prjc'}->get_verbatim($name);
- $self->append_current($val) if (defined $val);
- }
- sub handle_eval {
- my($self, $name) = @_;
- my $val = $self->get_value_with_default($name);
- if (defined $val) {
- if (index($val, "<%eval($name)%>") >= 0) {
- $self->warning("Infinite recursion detected in '$name'.");
- }
- else {
- ## Enter the eval state
- ++$self->{'eval'};
- ## Parse the eval line
- my($status, $error) = $self->parse_line(undef, $val);
- if ($status) {
- $self->{'built'} .= $self->{'eval_str'};
- }
- else {
- $self->warning($error);
- }
- ## Leave the eval state
- --$self->{'eval'};
- $self->{'eval_str'} = '';
- }
- }
- }
- sub handle_pseudo {
- my($self, $name) = @_;
- $self->append_current($self->{'cmds'}->{$name});
- }
- sub get_duplicate_index {
- my($self, $name) = @_;
- return $self->doif_duplicate_index($self->get_value_with_default($name));
- }
- sub doif_duplicate_index {
- my($self, $value) = @_;
- if (defined $value) {
- my $base = lc($self->tp_basename($value));
- my $path = $self->validated_dirname($value);
- if (!defined $self->{'dupfiles'}->{$base}) {
- $self->{'dupfiles'}->{$base} = [$path];
- }
- else {
- my $index = 1;
- foreach my $file (@{$self->{'dupfiles'}->{$base}}) {
- return $index if ($file eq $path);
- ++$index;
- }
- push(@{$self->{'dupfiles'}->{$base}}, $path);
- return 1;
- }
- }
- return undef;
- }
- sub handle_duplicate_index {
- my($self, $name) = @_;
- my $value = $self->doif_duplicate_index(
- $self->get_value_with_default($name));
- $self->append_current($value) if (defined $value);
- }
- sub actual_transdir {
- my($self, $value) = @_;
- if ($value =~ /([\/\\])/) {
- return $self->{'prjc'}->translate_directory(
- $self->tp_dirname($value)) . $1;
- }
- return undef;
- }
- sub get_transdir {
- my($self, $name) = @_;
- return $self->actual_transdir($self->get_value_with_default($name));
- }
- sub doif_transdir {
- my($self, $value) = @_;
- return (defined $value ? $self->actual_transdir($value) : undef);
- }
- sub handle_transdir {
- my($self, $name) = @_;
- my $value = $self->actual_transdir($self->get_value_with_default($name));
- $self->append_current($value) if (defined $value);
- }
- sub handle_create_aux_file {
- my $self = shift;
- my @fname = $self->perform_create_aux_file([$self->split_parameters(shift)]);
- $self->append_current($fname[0]);
- $self->post_create_aux_file();
- }
- sub post_create_aux_file {
- my $self = shift;
- $self->{'aux_file'} = $self->{'aux_temp'};
- $self->{'aux_temp'} = undef;
- }
- sub perform_create_aux_file {
- my($self, $argsref) = @_;
- if (defined $self->{'aux_file'}) {
- $self->{'error_in_handle'} = "Can't nest create_aux_file commands.";
- return undef;
- }
- my $fname = '';
- foreach my $arg (@$argsref) {
- my $val = $self->get_value($arg);
- $fname .= defined $val ?
- (UNIVERSAL::isa($val, 'ARRAY') ? join('_', @$val) : $val) : $arg;
- }
- my $dir = $self->mpc_dirname($self->{'prjc'}->get_outdir() . '/' .
- $self->{'prjc'}->{'assign'}->{'project_file'});
- $dir .= '/' . $self->mpc_dirname($fname) if ($fname =~ /[\/\\]/);
- $self->{'aux_temp'} = {'dir' => $dir,
- 'filename' => $self->mpc_basename($fname),
- 'foreach_baseline' => $self->{'foreach'}->{'count'}};
- return $fname;
- }
- sub handle_end_aux_file {
- my $self = shift;
- if (!defined $self->{'aux_file'}) {
- $self->{'error_in_handle'} = 'end_aux_file seen before create_aux_file';
- }
- else {
- my $af = $self->{'aux_file'};
- mkpath($af->{'dir'}, 0, 0777) if ($af->{'dir'} ne '.');
- my $fh = new FileHandle('> ' . $af->{'dir'} . '/' . $af->{'filename'});
- if (defined $fh) {
- print $fh $af->{'text'};
- close($fh);
- }
- else {
- $self->{'error_in_handle'} = "Couldn't open: " . $af->{'dir'} . '/' .
- $af->{'filename'};
- }
- $self->{'aux_file'} = undef;
- }
- }
- sub handle_translate_vars {
- my($self, $arg) = @_;
- my @params = $self->split_parameters($arg);
- $self->append_current($self->perform_translate_vars([@params]));
- }
- sub get_translate_vars {
- my ($self, $str) = @_;
- my @params = $self->split_parameters($str);
- return $self->perform_translate_vars([@params]);
- }
- sub perform_translate_vars {
- my($self, $arg) = @_;
- ## If the first parameter is a template variable with a value, use it.
- ## Otherwise, use the parameter as the value.
- my $val = $self->get_value($arg->[0]);
- $val = $arg->[0] unless defined $val;
- ## If the second optional parameter is provided, use it. Otherwise,
- ## use the operating system found in the command substitution map.
- my $os = (defined $arg->[1] && $arg->[1] ne '') ?
- $arg->[1] : $self->{'prjc'}->{'command_subs'}->{'os'};
- ## Get the variable reference characters based on the operating system
- ## for which we are generating this project.
- my ($pre, $post) = ($os eq 'win32') ? ('%', '%') : ('${', '}');
- ## Replace $() with the environment variable reference characters.
- $val =~ s{\$\(([^)]+)\)([^\s\$]*)}{my ($var, $rest) = ($1, $2);
- $rest =~ s!/!\\!g if $os eq 'win32';
- "$pre$var$post$rest"}ge;
- return $val;
- }
- sub handle_convert_slashes {
- my($self, $arg) = @_;
- my @params = $self->split_parameters($arg);
- $self->append_current($self->perform_convert_slashes([@params]));
- }
- sub perform_convert_slashes {
- my($self, $arg) = @_;
- ## If the first parameter is a template variable with a value, use it.
- ## Otherwise, use the parameter as the value.
- my $val = $self->get_value($arg->[0]);
- $val = $arg->[0] unless defined $val;
- ## If the second optional parameter is provided, use it. Otherwise,
- ## use the operating system found in the command substitution map.
- my $os = (defined $arg->[1] && $arg->[1] ne '') ?
- $arg->[1] : $self->{'prjc'}->{'command_subs'}->{'os'};
- ## Replace forward slashes with backslashes if we're generating this
- ## project specific to Windows.
- $val =~ s!/!\\!g if $os eq 'win32';
- return $val;
- }
- sub handle_new_guid {
- my($self, $name) = @_;
- my $val = $self->get_value_with_default($name);
- my $prjc = $self->{'prjc'};
- my $guid = GUID::generate($val ? $val : $name,
- $prjc->{'current_input'},
- File::Spec->abs2rel($prjc->getcwd(),
- $prjc->getstartdir()));
- $self->append_current($guid);
- }
- sub handle_deref {
- my($self, $name) = @_;
- my $val = $self->get_value_with_default($self->get_value_with_default($name));
- $self->append_current($val);
- }
- sub handle_set {
- my($self, $val) = @_;
- my @params = $self->split_parameters($val);
- if ($#params == 1) {
- $self->{'values'}->{lc($params[0])} = $params[1];
- }
- else {
- $self->{'error_in_handle'} = 'set() requires a name and a value';
- }
- }
- sub prepare_parameters {
- my($self, $prefix) = @_;
- my $input = $self->get_value($prefix . '->input_file');
- my $output;
- my $indir;
- my $outdir;
- if (defined $input) {
- $input =~ s/\//\\/g if ($self->{'cslashes'});
- $indir = $self->tp_dirname($input);
- $output = $self->get_value($prefix . '->input_file->output_files');
- if (defined $output) {
- my $size = scalar(@$output);
- for(my $i = 0; $i < $size; ++$i) {
- my $fo = $self->get_flag_overrides($prefix . '->input_file, gendir');
- if (defined $fo) {
- $outdir = $self->tp_dirname($$output[$i]);
- if (!($outdir ne '' && $indir ne $outdir && $fo ne $outdir)) {
- $$output[$i] = ($fo eq '.' ? '' : $fo . '/') .
- $self->tp_basename($$output[$i]);
- }
- }
- $$output[$i] =~ s/\//\\/g if ($self->{'cslashes'});
- }
- }
- }
- ## Set the parameters array with the determined input and output files
- return $input, $output;
- }
- sub process_name {
- my($self, $line) = @_;
- my $length = 0;
- my $errorString;
- ## Split the line into a name and value
- if ($line =~ /$process_name_re1/) {
- my $name = lc($1);
- my $val = $3;
- $length += length($name);
- if (defined $val) {
- ## Check for the parenthesis
- if (($val =~ tr/(//) != ($val =~ tr/)//)) {
- return 'Missing the closing parenthesis', $length;
- }
- ## Add the length of the value plus 2 for the surrounding ()
- $length += length($val) + 2;
- }
- if (defined $keywords{$name}) {
- if ($name eq 'if') {
- $self->handle_if($val);
- }
- elsif ($name eq 'endif') {
- $errorString = $self->handle_endif($name);
- }
- elsif ($name eq 'else') {
- $errorString = $self->handle_else();
- }
- elsif ($name eq 'endfor') {
- $errorString = $self->handle_endfor($name);
- }
- elsif ($name eq 'foreach') {
- $errorString = $self->handle_foreach($val);
- }
- elsif ($name eq 'fornotlast' || $name eq 'forlast' ||
- $name eq 'fornotfirst' || $name eq 'forfirst') {
- if (!$self->{'if_skip'}) {
- $self->handle_special($name, $self->process_special($val));
- }
- }
- elsif ($name eq 'comment') {
- ## Ignore the contents of the comment
- }
- else {
- if (!$self->{'if_skip'}) {
- if (index($val, '(') >= 0) {
- $self->evaluate_nested_functions($name, $val);
- }
- else {
- my $func = 'handle_' . $name;
- $self->$func($val);
- if ($self->{'error_in_handle'}) {
- $errorString = $self->{'error_in_handle'};
- }
- }
- }
- }
- }
- elsif (defined $self->{'cmds'}->{$name}) {
- $self->handle_pseudo($name) if (!$self->{'if_skip'});
- }
- else {
- if (!$self->{'if_skip'}) {
- if (defined $val && !defined $self->{'defaults'}->{$name}) {
- $self->{'defaults'}->{$name} = $self->process_special($val);
- }
- $self->append_current($self->get_value_with_default($name));
- }
- }
- }
- else {
- my $error = $line;
- my $length = length($line);
- for(my $i = 0; $i < $length; ++$i) {
- my $part = substr($line, $i, 2);
- if ($part eq '%>') {
- $error = substr($line, 0, $i + 2);
- last;
- }
- }
- $errorString = "Unable to parse line starting at '$error'";
- }
- return $errorString, $length;
- }
- sub collect_data {
- my $self = shift;
- my $prjc = $self->{'prjc'};
- my $cwd = $self->getcwd();
- ## Set the current working directory
- $cwd =~ s/\//\\/g if ($self->{'cslashes'});
- $self->{'values'}->{'cwd'} = $cwd;
- ## Collect the components into {'values'} somehow
- foreach my $key (keys %{$prjc->{'valid_components'}}) {
- my @list = $prjc->get_component_list($key);
- $self->{'values'}->{$key} = \@list if (defined $list[0]);
- }
- ## If there is a staticname and no sharedname then this project
- ## 'type_is_static'. If we are generating static projects, let
- ## all of the templates know that we 'need_staticflags'.
- ## If there is a sharedname then this project 'type_is_dynamic'.
- my $sharedname = $prjc->get_assignment('sharedname');
- my $staticname = $prjc->get_assignment('staticname');
- if (!defined $sharedname && defined $staticname) {
- $self->{'override_target_type'} = 1;
- $self->{'values'}->{'type_is_static'} = 1;
- $self->{'values'}->{'need_staticflags'} = 1;
- }
- elsif ($prjc->get_static() == 1) {
- $self->{'values'}->{'need_staticflags'} = 1;
- }
- elsif (defined $sharedname) {
- $self->{'values'}->{'type_is_dynamic'} = 1;
- }
- ## If there is a sharedname or exename then this project
- ## 'type_is_binary'.
- if (defined $sharedname ||
- defined $prjc->get_assignment('exename')) {
- $self->{'values'}->{'type_is_binary'} = 1;
- }
- ## A tiny hack (mainly for VC6 projects)
- ## for the workspace creator. It needs to know the
- ## target names to match up with the project name.
- $prjc->update_project_info($self, 0, ['project_name']);
- ## This is for all projects
- $prjc->update_project_info($self, 1, ['after']);
- ## VC7 Projects need to know the GUID.
- ## We need to save this value in our known values
- ## since each guid generated will be different. We need
- ## this to correspond to the same guid used in the workspace.
- my $guid = $prjc->update_project_info($self, 1, ['guid']);
- $self->{'values'}->{'guid'} = $guid;
- ## In order for VC7 to mix languages, we need to keep track
- ## of the language associated with each project.
- $prjc->update_project_info($self, 1, ['language']);
- ## For VC7+ to properly work with wince, which is cross compiled,
- ## a new platform-specific token is added, nocross, which is used
- ## to determine if a project is even to be built for non-native
- ## targets. Additionally, custom-only projects are built but not
- ## deployed, thus these are added to the project_info mix
- $prjc->update_project_info($self, 1, ['custom_only']);
- $prjc->update_project_info($self, 1, ['nocross']);
- ## For VC8 to be able to add references to managed DLL's to the current
- ## managed DLL project (if it is one), we need to keep track of whether
- ## the project is 'managed' or not.
- $prjc->update_project_info($self, 1, ['managed']);
- ## For WiX, only generate top-level groups for projects marked with "make_group"
- $prjc->update_project_info($self, 1, ['make_group']);
- ## Some Windows based projects can't deal with certain version
- ## values. So, for those we provide a translated version.
- my $version = $prjc->get_assignment('version');
- if (defined $version) {
- $self->{'values'}->{'win_version'} =
- WinVersionTranslator::translate($version);
- }
- }
- sub parse_line {
- my($self, $ih, $line) = @_;
- my $errorString;
- my $startempty = ($line eq '');
- ## If processing a foreach or the line only
- ## contains a keyword, then we do
- ## not need to add a newline to the end.
- if ($self->{'foreach'}->{'processing'} == 0 && !$self->{'eval'} &&
- ($line !~ /$parse_line_re1/ || !defined $keywords{$1})) {
- $line .= $self->{'crlf'};
- }
- if ($self->{'foreach'}->{'count'} < 0 && !$self->{'eval'}) {
- $self->{'built'} = '';
- }
- my $start = index($line, '<%');
- if ($start >= 0) {
- my $append_name;
- if ($start > 0) {
- if (!$self->{'if_skip'}) {
- $self->append_current(substr($line, 0, $start));
- }
- $line = substr($line, $start);
- }
- my $nlen = 0;
- foreach my $item (split('<%', $line)) {
- my $name = 1;
- my $length = length($item);
- my $endi = index($item, '%>');
- for(my $i = 0; $i < $length; ++$i) {
- if ($i == $endi) {
- ++$i;
- $endi = index($item, '%>', $i);
- $name = undef;
- if ($append_name) {
- $append_name = undef;
- if (!$self->{'if_skip'}) {
- $self->append_current('%>');
- }
- }
- if ($length != $i + 1) {
- if (!$self->{'if_skip'}) {
- $self->append_current(substr($item, $i + 1));
- }
- last;
- }
- }
- elsif ($name) {
- my $efcheck = (index($item, 'endfor%>') == 0);
- my $focheck = ($efcheck ? 0 : (index($item, 'foreach(') == 0));
- if ($focheck && $self->{'foreach'}->{'count'} >= 0) {
- ++$self->{'foreach'}->{'nested'};
- }
- if ($self->{'foreach'}->{'count'} < 0 ||
- $self->{'foreach'}->{'processing'} > $self->{'foreach'}->{'nested'} ||
- (($efcheck || $focheck) &&
- $self->{'foreach'}->{'nested'} == $self->{'foreach'}->{'processing'})) {
- ($errorString, $nlen) = $self->process_name($item);
- if (defined $errorString) {
- return 0, $errorString;
- }
- elsif ($nlen == 0) {
- return 0, "Could not parse this line at column $i";
- }
- $i += ($nlen - 1);
- }
- else {
- $name = undef;
- $nlen = ($i < $endi ? $endi : $length) - $i;
- if (!$self->{'if_skip'}) {
- $self->append_current('<%' . substr($item, $i, $nlen));
- $append_name = 1;
- }
- $i += ($nlen - 1);
- }
- if ($efcheck && $self->{'foreach'}->{'nested'} > 0) {
- --$self->{'foreach'}->{'nested'};
- }
- }
- else {
- $nlen = ($i < $endi ? $endi : $length) - $i;
- if (!$self->{'if_skip'}) {
- $self->append_current(substr($item, $i, $nlen));
- }
- $i += ($nlen - 1);
- }
- }
- }
- }
- else {
- $self->append_current($line) if (!$self->{'if_skip'});
- }
- if ($self->{'foreach'}->{'count'} < 0 && !$self->{'eval'} &&
- ## If the line started out empty and we're not
- ## skipping from the start or the built up line is not empty
- ($startempty ||
- ($self->{'built'} ne $self->{'crlf'} && $self->{'built'} ne ''))) {
- push(@{$self->{'lines'}}, $self->{'built'});
- }
- return !defined $errorString, $errorString;
- }
- sub parse_file {
- my($self, $input) = @_;
- $self->collect_data();
- my($status, $errorString) = $self->cached_file_read($input);
- ## If there was no error, check the stack to make sure that we aren't
- ## missing an <%endif%> or an <%endfor%>.
- if ($status && defined $self->{'sstack'}->[0]) {
- $status = 0;
- $errorString = "Missing an '$self->{'sstack'}->[0]' starting at " .
- $self->{'lstack'}->[0];
- }
- ## Add in the line number if there is an error
- $errorString = "$input: line " .
- $self->get_line_number() . ":\n$errorString" if (!$status);
- return $status, $errorString;
- }
- sub get_lines {
- return $_[0]->{'lines'};
- }
- # ************************************************************
- # Accessors used by support scripts
- # ************************************************************
- sub getKeywords {
- return \%keywords;
- }
- sub getArrowOp {
- return \%arrow_op_ref;
- }
- 1;