sub main()

in src/interfaces/ecpg/preproc/parse.pl [135:435]

• 248 lines of code
• 48 McCabe index (conditional complexity)

sub main
{
  line: while (<>)
	{
		if (/ERRCODE_FEATURE_NOT_SUPPORTED/)
		{
			$feature_not_supported = 1;
			next line;
		}

		chomp;

		# comment out the line below to make the result file match (blank line wise)
		# the prior version.
		#next if ($_ eq '');

		# Dump the action for a rule -
		# stmt_mode indicates if we are processing the 'stmt:'
		# rule (mode==0 means normal,  mode==1 means stmt:)
		# flds are the fields to use. These may start with a '$' - in
		# which case they are the result of a previous non-terminal
		#
		# if they don't start with a '$' then they are token name
		#
		# len is the number of fields in flds...
		# leadin is the padding to apply at the beginning (just use for formatting)

		if (/^%%/)
		{
			$tokenmode = 2;
			$copymode  = 1;
			$yaccmode++;
			$infield = 0;
		}

		my $prec = 0;

		# Make sure any braces are split
		s/{/ { /g;
		s/}/ } /g;

		# Any comments are split
		s|\/\*| /* |g;
		s|\*\/| */ |g;

		# Now split the line into individual fields
		my @arr = split(' ');

		if ($arr[0] eq '%token' && $tokenmode == 0)
		{
			$tokenmode = 1;
			include_file('tokens', 'ecpg.tokens');
		}
		elsif ($arr[0] eq '%type' && $header_included == 0)
		{
			include_file('header',   'ecpg.header');
			include_file('ecpgtype', 'ecpg.type');
			$header_included = 1;
		}

		if ($tokenmode == 1)
		{
			my $str   = '';
			my $prior = '';
			for my $a (@arr)
			{
				if ($a eq '/*')
				{
					$comment++;
					next;
				}
				if ($a eq '*/')
				{
					$comment--;
					next;
				}
				if ($comment)
				{
					next;
				}
				if (substr($a, 0, 1) eq '<')
				{
					next;

					# its a type
				}
				$tokens{$a} = 1;

				$str = $str . ' ' . $a;
				if ($a eq 'IDENT' && $prior eq '%nonassoc')
				{

					# add more tokens to the list
					$str = $str . "\n%nonassoc CSTRING";
				}
				$prior = $a;
			}
			add_to_buffer('orig_tokens', $str);
			next line;
		}

		# Don't worry about anything if we're not in the right section of gram.y
		if ($yaccmode != 1)
		{
			next line;
		}


		# Go through each field in turn
		for (
			my $fieldIndexer = 0;
			$fieldIndexer < scalar(@arr);
			$fieldIndexer++)
		{
			if ($arr[$fieldIndexer] eq '*/' && $comment)
			{
				$comment = 0;
				next;
			}
			elsif ($comment)
			{
				next;
			}
			elsif ($arr[$fieldIndexer] eq '/*')
			{

				# start of a multiline comment
				$comment = 1;
				next;
			}
			elsif ($arr[$fieldIndexer] eq '//')
			{
				next line;
			}
			elsif ($arr[$fieldIndexer] eq '}')
			{
				$brace_indent--;
				next;
			}
			elsif ($arr[$fieldIndexer] eq '{')
			{
				$brace_indent++;
				next;
			}

			if ($brace_indent > 0)
			{
				next;
			}
			if ($arr[$fieldIndexer] eq ';')
			{
				if ($copymode)
				{
					if ($infield)
					{
						dump_line($stmt_mode, \@fields);
					}
					add_to_buffer('rules', ";\n\n");
				}
				else
				{
					$copymode = 1;
				}
				@fields  = ();
				$infield = 0;
				$line    = '';
				$in_rule = 0;
				next;
			}

			if ($arr[$fieldIndexer] eq '|')
			{
				if ($copymode)
				{
					if ($infield)
					{
						$infield = $infield + dump_line($stmt_mode, \@fields);
					}
					if ($infield > 1)
					{
						$line = '| ';
					}
				}
				@fields = ();
				next;
			}

			if (exists $replace_token{ $arr[$fieldIndexer] })
			{
				$arr[$fieldIndexer] = $replace_token{ $arr[$fieldIndexer] };
			}

			# Are we looking at a declaration of a non-terminal ?
			if (($arr[$fieldIndexer] =~ /[A-Za-z0-9]+:/)
				|| $arr[ $fieldIndexer + 1 ] eq ':')
			{
				$non_term_id = $arr[$fieldIndexer];
				$non_term_id =~ tr/://d;

				if (not defined $replace_types{$non_term_id})
				{
					$replace_types{$non_term_id} = '<str>';
					$copymode = 1;
				}
				elsif ($replace_types{$non_term_id} eq 'ignore')
				{
					$copymode = 0;
					$line     = '';
					next line;
				}
				$line = $line . ' ' . $arr[$fieldIndexer];

				# Do we have the : attached already ?
				# If yes, we'll have already printed the ':'
				if (!($arr[$fieldIndexer] =~ '[A-Za-z0-9]+:'))
				{

					# Consume the ':' which is next...
					$line = $line . ':';
					$fieldIndexer++;
				}

				# Special mode?
				if ($non_term_id eq 'stmt')
				{
					$stmt_mode = 1;
				}
				else
				{
					$stmt_mode = 0;
				}
				my $tstr =
				    '%type '
				  . $replace_types{$non_term_id} . ' '
				  . $non_term_id;
				add_to_buffer('types', $tstr);

				if ($copymode)
				{
					add_to_buffer('rules', $line);
				}
				$line    = '';
				@fields  = ();
				$infield = 1;
				die "unterminated rule at grammar line $.\n"
				  if $in_rule;
				$in_rule = 1;
				next;
			}
			elsif ($copymode)
			{
				$line = $line . ' ' . $arr[$fieldIndexer];
			}
			if ($arr[$fieldIndexer] eq '%prec')
			{
				$prec = 1;
				next;
			}

			if (   $copymode
				&& !$prec
				&& !$comment
				&& length($arr[$fieldIndexer])
				&& $infield)
			{
				if ($arr[$fieldIndexer] ne 'Op'
					&& (   $tokens{ $arr[$fieldIndexer] } > 0
						|| $arr[$fieldIndexer] =~ /'.+'/)
					|| $stmt_mode == 1)
				{
					my $S;
					if (exists $replace_string{ $arr[$fieldIndexer] })
					{
						$S = $replace_string{ $arr[$fieldIndexer] };
					}
					else
					{
						$S = $arr[$fieldIndexer];
					}
					$S =~ s/_P//g;
					$S =~ tr/'//d;
					if ($stmt_mode == 1)
					{
						push(@fields, $S);
					}
					else
					{
						push(@fields, lc($S));
					}
				}
				else
				{
					push(@fields, '$' . (scalar(@fields) + 1));
				}
			}
		}
	}
	die "unterminated rule at end of grammar\n"
	  if $in_rule;
	return;
}