#!/usr/bin/perl -w

# (c) 2001, Dave Jones. (the file handling bit)

# (c) 2005, Joel Schopp <jschopp@austin.ibm.com> (the ugly bit)

# (c) 2007,2008, Andy Whitcroft <apw@uk.ibm.com> (new conditions, test suite)

# (c) 2008-2010 Andy Whitcroft <apw@canonical.com>

# Licensed under the terms of the GNU GPL License version 2

use strict;

my $P = $0;

$P =~ s@.*/@@g;

my $V = '0.32';

use Getopt::Long qw(:config no_auto_abbrev);

my $quiet = 0;

my $tree = 1;

my $chk_signoff = 1;

my $chk_patch = 1;

my $tst_only;

my $emacs = 0;

my $terse = 0;

my $file = 0;

my $check = 0;

my $summary = 1;

my $mailback = 0;

my $summary_file = 0;

my $show_types = 0;

my $root;

my %debug;

my %ignore_type = ();

my @ignore = ();

my $help = 0;

my $configuration_file = ".checkpatch.conf";

sub help {

my ($exitcode) = @_;

print << "EOM";

Usage: $P [OPTION]... [FILE]...

Version: $V

Options:

-q, --quiet quiet

--no-tree run without a kernel tree

--no-signoff do not check for 'Signed-off-by' line

--patch treat FILE as patchfile (default)

--emacs emacs compile window format

--terse one line per report

-f, --file treat FILE as regular source file

--subjective, --strict enable more subjective tests

--ignore TYPE(,TYPE2...) ignore various comma separated message types

--show-types show the message "types" in the output

--root=PATH PATH to the kernel tree root

--no-summary suppress the per-file summary

--mailback only produce a report in case of warnings/errors

--summary-file include the filename in summary

--debug KEY=[0|1] turn on/off debugging of KEY, where KEY is one of

'values', 'possible', 'type', and 'attr' (default

is all off)

--test-only=WORD report only warnings/errors containing WORD

literally

-h, --help, --version display this help and exit

When FILE is - read standard input.

EOM

exit($exitcode);

}

my $conf = which_conf($configuration_file);

if (-f $conf) {

my @conf_args;

open(my $conffile, '<', "$conf")

or warn "$P: Can't find a readable $configuration_file file $!\n";

while (<$conffile>) {

my $line = $_;

$line =~ s/\s*\n?$//g;

$line =~ s/^\s*//g;

$line =~ s/\s+/ /g;

next if ($line =~ m/^\s*#/);

next if ($line =~ m/^\s*$/);

my @words = split(" ", $line);

foreach my $word (@words) {

last if ($word =~ m/^#/);

push (@conf_args, $word);

}

}

close($conffile);

unshift(@ARGV, @conf_args) if @conf_args;

}

GetOptions(

'q|quiet+' => \$quiet,

'tree!' => \$tree,

'signoff!' => \$chk_signoff,

'patch!' => \$chk_patch,

'emacs!' => \$emacs,

'terse!' => \$terse,

'f|file!' => \$file,

'subjective!' => \$check,

'strict!' => \$check,

'ignore=s' => \@ignore,

'show-types!' => \$show_types,

'root=s' => \$root,

'summary!' => \$summary,

'mailback!' => \$mailback,

'summary-file!' => \$summary_file,

'debug=s' => \%debug,

'test-only=s' => \$tst_only,

'h|help' => \$help,

'version' => \$help

) or help(1);

help(0) if ($help);

my $exit = 0;

if ($#ARGV < 0) {

print "$P: no input files\n";

exit(1);

}

@ignore = split(/,/, join(',',@ignore));

foreach my $word (@ignore) {

$word =~ s/\s*\n?$//g;

$word =~ s/^\s*//g;

$word =~ s/\s+/ /g;

$word =~ tr/[a-z]/[A-Z]/;

next if ($word =~ m/^\s*#/);

next if ($word =~ m/^\s*$/);

$ignore_type{$word}++;

}

my $dbg_values = 0;

my $dbg_possible = 0;

my $dbg_type = 0;

my $dbg_attr = 0;

for my $key (keys %debug) {

## no critic

eval "\${dbg_$key} = '$debug{$key}';";

die "$@" if ($@);

}

my $rpt_cleaners = 0;

if ($terse) {

$emacs = 1;

$quiet++;

}

if ($tree) {

if (defined $root) {

if (!top_of_kernel_tree($root)) {

die "$P: $root: --root does not point at a valid tree\n";

}

} else {

if (top_of_kernel_tree('.')) {

$root = '.';

} elsif ($0 =~ m@(.*)/scripts/[^/]*$@ &&

top_of_kernel_tree($1)) {

$root = $1;

}

}

if (!defined $root) {

print "Must be run from the top-level dir. of a kernel tree\n";

exit(2);

}

}

my $emitted_corrupt = 0;

our $Ident = qr{

[A-Za-z_][A-Za-z\d_]*

(?:\s*\#\#\s*[A-Za-z_][A-Za-z\d_]*)*

}x;

our $Storage = qr{extern|static|asmlinkage};

our $Sparse = qr{

__user|

__kernel|

__force|

__iomem|

__must_check|

__init_refok|

__kprobes|

__ref|

__rcu

}x;

# Notes to $Attribute:

# We need \b after 'init' otherwise 'initconst' will cause a false positive in a check

our $Attribute = qr{

const|

__percpu|

__nocast|

__safe|

__bitwise__|

__packed__|

__packed2__|

__naked|

__maybe_unused|

__always_unused|

__noreturn|

__used|

__cold|

__noclone|

__deprecated|

__read_mostly|

__kprobes|

__(?:mem|cpu|dev|)(?:initdata|initconst|init\b)|

____cacheline_aligned|

____cacheline_aligned_in_smp|

____cacheline_internodealigned_in_smp|

__weak

}x;

our $Modifier;

our $Inline = qr{inline|__always_inline|noinline};

our $Member = qr{->$Ident|\.$Ident|\[[^]]*\]};

our $Lval = qr{$Ident(?:$Member)*};

our $Constant = qr{(?i:(?:[0-9]+|0x[0-9a-f]+)[ul]*)};

our $Assignment = qr{(?:\*\=|/=|%=|\+=|-=|<<=|>>=|&=|\^=|\|=|=)};

our $Compare = qr{<=|>=|==|!=|<|>};

our $Operators = qr{

<=|>=|==|!=|

=>|->|<<|>>|<|>|!|~|

&&|\|\||,|\^|\+\+|--|&|\||\+|-|\*|\/|%

}x;

our $NonptrType;

our $Type;

our $Declare;

our $NON_ASCII_UTF8 = qr{

[\xC2-\xDF][\x80-\xBF] # non-overlong 2-byte

| \xE0[\xA0-\xBF][\x80-\xBF] # excluding overlongs

| [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2} # straight 3-byte

| \xED[\x80-\x9F][\x80-\xBF] # excluding surrogates

| \xF0[\x90-\xBF][\x80-\xBF]{2} # planes 1-3

| [\xF1-\xF3][\x80-\xBF]{3} # planes 4-15

| \xF4[\x80-\x8F][\x80-\xBF]{2} # plane 16

}x;

our $UTF8 = qr{

[\x09\x0A\x0D\x20-\x7E] # ASCII

| $NON_ASCII_UTF8

}x;

our $typeTypedefs = qr{(?x:

(?:__)?(?:u|s|be|le)(?:8|16|32|64)|

atomic_t

)};

our $logFunctions = qr{(?x:

printk(?:_ratelimited|_once|)|

[a-z0-9]+_(?:printk|emerg|alert|crit|err|warning|warn|notice|info|debug|dbg|vdbg|devel|cont|WARN)(?:_ratelimited|_once|)|

WARN(?:_RATELIMIT|_ONCE|)|

panic|

MODULE_[A-Z_]+

)};

our $signature_tags = qr{(?xi:

Signed-off-by:|

Acked-by:|

Tested-by:|

Reviewed-by:|

Reported-by:|

To:|

Cc:

)};

our @typeList = (

qr{void},

qr{(?:unsigned\s+)?char},

qr{(?:unsigned\s+)?short},

qr{(?:unsigned\s+)?int},

qr{(?:unsigned\s+)?long},

qr{(?:unsigned\s+)?long\s+int},

qr{(?:unsigned\s+)?long\s+long},

qr{(?:unsigned\s+)?long\s+long\s+int},

qr{unsigned},

qr{float},

qr{double},

qr{bool},

qr{struct\s+$Ident},

qr{union\s+$Ident},

qr{enum\s+$Ident},

qr{${Ident}_t},

qr{${Ident}_handler},

qr{${Ident}_handler_fn},

);

our @modifierList = (

qr{fastcall},

);

our $allowed_asm_includes = qr{(?x:

irq|

memory

)};

# memory.h: ARM has a custom one

sub build_types {

my $mods = "(?x: \n" . join("|\n ", @modifierList) . "\n)";

my $all = "(?x: \n" . join("|\n ", @typeList) . "\n)";

$Modifier = qr{(?:$Attribute|$Sparse|$mods)};

$NonptrType = qr{

(?:$Modifier\s+|const\s+)*

(?:

(?:typeof|__typeof__)\s*\([^\)]*\)|

(?:$typeTypedefs\b)|

(?:${all}\b)

)

(?:\s+$Modifier|\s+const)*

}x;

$Type = qr{

$NonptrType

(?:(?:\s|\*|\[\])+\s*const|(?:\s|\*|\[\])+|(?:\s*\[\s*\])+)?

(?:\s+$Inline|\s+$Modifier)*

}x;

$Declare = qr{(?:$Storage\s+)?$Type};

}

build_types();

our $Typecast = qr{\s*(\(\s*$NonptrType\s*\)){0,1}\s*};

# Using $balanced_parens, $LvalOrFunc, or $FuncArg

# requires at least perl version v5.10.0

# Any use must be runtime checked with $^V

our $balanced_parens = qr/(\((?:[^\(\)]++|(?-1))*\))/;

our $LvalOrFunc = qr{($Lval)\s*($balanced_parens{0,1})\s*};

our $FuncArg = qr{$Typecast{0,1}($LvalOrFunc|$Constant)};

sub deparenthesize {

my ($string) = @_;

return "" if (!defined($string));

$string =~ s@^\s*\(\s*@@g;

$string =~ s@\s*\)\s*$@@g;

$string =~ s@\s+@ @g;

return $string;

}

$chk_signoff = 0 if ($file);

my @dep_includes = ();

my @dep_functions = ();

my $removal = "Documentation/feature-removal-schedule.txt";

if ($tree && -f "$root/$removal") {

open(my $REMOVE, '<', "$root/$removal") ||

die "$P: $removal: open failed - $!\n";

while (<$REMOVE>) {

if (/^Check:\s+(.*\S)/) {

for my $entry (split(/[, ]+/, $1)) {

if ($entry =~ m@include/(.*)@) {

push(@dep_includes, $1);

} elsif ($entry !~ m@/@) {

push(@dep_functions, $entry);

}

}

}

}

close($REMOVE);

}

my @rawlines = ();

my @lines = ();

my $vname;

for my $filename (@ARGV) {

my $FILE;

if ($file) {

open($FILE, '-|', "diff -u /dev/null $filename") ||

die "$P: $filename: diff failed - $!\n";

} elsif ($filename eq '-') {

open($FILE, '<&STDIN');

} else {

open($FILE, '<', "$filename") ||

die "$P: $filename: open failed - $!\n";

}

if ($filename eq '-') {

$vname = 'Your patch';

} else {

$vname = $filename;

}

while (<$FILE>) {

chomp;

push(@rawlines, $_);

}

close($FILE);

if (!process($filename)) {

$exit = 1;

}

@rawlines = ();

@lines = ();

}

exit($exit);

sub top_of_kernel_tree {

my ($root) = @_;

my @tree_check = (

"COPYING", "CREDITS", "Kbuild", "MAINTAINERS", "Makefile",

"README", "Documentation", "arch", "include", "drivers",

"fs", "init", "ipc", "kernel", "lib", "scripts",

);

foreach my $check (@tree_check) {

if (! -e $root . '/' . $check) {

return 0;

}

}

return 1;

}

sub parse_email {

my ($formatted_email) = @_;

my $name = "";

my $address = "";

my $comment = "";

if ($formatted_email =~ /^(.*)<(\S+\@\S+)>(.*)$/) {

$name = $1;

$address = $2;

$comment = $3 if defined $3;

} elsif ($formatted_email =~ /^\s*<(\S+\@\S+)>(.*)$/) {

$address = $1;

$comment = $2 if defined $2;

} elsif ($formatted_email =~ /(\S+\@\S+)(.*)$/) {

$address = $1;

$comment = $2 if defined $2;

$formatted_email =~ s/$address.*$//;

$name = $formatted_email;

$name =~ s/^\s+|\s+$//g;

$name =~ s/^\"|\"$//g;

# If there's a name left after stripping spaces and

# leading quotes, and the address doesn't have both

# leading and trailing angle brackets, the address

# is invalid. ie:

# "joe smith joe@smith.com" bad

# "joe smith <joe@smith.com" bad

if ($name ne "" && $address !~ /^<[^>]+>$/) {

$name = "";

$address = "";

$comment = "";

}

}

$name =~ s/^\s+|\s+$//g;

$name =~ s/^\"|\"$//g;

$address =~ s/^\s+|\s+$//g;

$address =~ s/^\<|\>$//g;

if ($name =~ /[^\w \-]/i) { ##has "must quote" chars

$name =~ s/(?<!\\)"/\\"/g; ##escape quotes

$name = "\"$name\"";

}

return ($name, $address, $comment);

}

sub format_email {

my ($name, $address) = @_;

my $formatted_email;

$name =~ s/^\s+|\s+$//g;

$name =~ s/^\"|\"$//g;

$address =~ s/^\s+|\s+$//g;

if ($name =~ /[^\w \-]/i) { ##has "must quote" chars

$name =~ s/(?<!\\)"/\\"/g; ##escape quotes

$name = "\"$name\"";

}

if ("$name" eq "") {

$formatted_email = "$address";

} else {

$formatted_email = "$name <$address>";

}

return $formatted_email;

}

sub which_conf {

my ($conf) = @_;

foreach my $path (split(/:/, ".:$ENV{HOME}:.scripts")) {

if (-e "$path/$conf") {

return "$path/$conf";

}

}

return "";

}

sub expand_tabs {

my ($str) = @_;

my $res = '';

my $n = 0;

for my $c (split(//, $str)) {

if ($c eq "\t") {

$res .= ' ';

$n++;

for (; ($n % 8) != 0; $n++) {

$res .= ' ';

}

next;

}

$res .= $c;

$n++;

}

return $res;

}

sub copy_spacing {

(my $res = shift) =~ tr/\t/ /c;

return $res;

}

sub line_stats {

my ($line) = @_;

# Drop the diff line leader and expand tabs

$line =~ s/^.//;

$line = expand_tabs($line);

# Pick the indent from the front of the line.

my ($white) = ($line =~ /^(\s*)/);

return (length($line), length($white));

}

my $sanitise_quote = '';

sub sanitise_line_reset {

my ($in_comment) = @_;

if ($in_comment) {

$sanitise_quote = '*/';

} else {

$sanitise_quote = '';

}

}

sub sanitise_line {

my ($line) = @_;

my $res = '';

my $l = '';

my $qlen = 0;

my $off = 0;

my $c;

# Always copy over the diff marker.

$res = substr($line, 0, 1);

for ($off = 1; $off < length($line); $off++) {

$c = substr($line, $off, 1);

# Comments we are wacking completly including the begin

# and end, all to $;.

if ($sanitise_quote eq '' && substr($line, $off, 2) eq '/*') {

$sanitise_quote = '*/';

substr($res, $off, 2, "$;$;");

$off++;

next;

}

if ($sanitise_quote eq '*/' && substr($line, $off, 2) eq '*/') {

$sanitise_quote = '';

substr($res, $off, 2, "$;$;");

$off++;

next;

}

if ($sanitise_quote eq '' && substr($line, $off, 2) eq '//') {

$sanitise_quote = '//';

substr($res, $off, 2, $sanitise_quote);

$off++;

next;

}

# A \ in a string means ignore the next character.

if (($sanitise_quote eq "'" || $sanitise_quote eq '"') &&

$c eq "\\") {

substr($res, $off, 2, 'XX');

$off++;

next;

}

# Regular quotes.

if ($c eq "'" || $c eq '"') {

if ($sanitise_quote eq '') {

$sanitise_quote = $c;

substr($res, $off, 1, $c);

next;

} elsif ($sanitise_quote eq $c) {

$sanitise_quote = '';

}

}

#print "c<$c> SQ<$sanitise_quote>\n";

if ($off != 0 && $sanitise_quote eq '*/' && $c ne "\t") {

substr($res, $off, 1, $;);

} elsif ($off != 0 && $sanitise_quote eq '//' && $c ne "\t") {

substr($res, $off, 1, $;);

} elsif ($off != 0 && $sanitise_quote && $c ne "\t") {

substr($res, $off, 1, 'X');

} else {

substr($res, $off, 1, $c);

}

}

if ($sanitise_quote eq '//') {

$sanitise_quote = '';

}

# The pathname on a #include may be surrounded by '<' and '>'.

if ($res =~ /^.\s*\#\s*include\s+\<(.*)\>/) {

my $clean = 'X' x length($1);

$res =~ s@\<.*\>@<$clean>@;

# The whole of a #error is a string.

} elsif ($res =~ /^.\s*\#\s*(?:error|warning)\s+(.*)\b/) {

my $clean = 'X' x length($1);

$res =~ s@(\#\s*(?:error|warning)\s+).*@$1$clean@;

}

return $res;

}

sub ctx_statement_block {

my ($linenr, $remain, $off) = @_;

my $line = $linenr - 1;

my $blk = '';

my $soff = $off;

my $coff = $off - 1;

my $coff_set = 0;

my $loff = 0;

my $type = '';

my $level = 0;

my @stack = ();

my $p;

my $c;

my $len = 0;

my $remainder;

while (1) {

@stack = (['', 0]) if ($#stack == -1);

#warn "CSB: blk<$blk> remain<$remain>\n";

# If we are about to drop off the end, pull in more

# context.

if ($off >= $len) {

for (; $remain > 0; $line++) {

last if (!defined $lines[$line]);

next if ($lines[$line] =~ /^-/);

$remain--;

$loff = $len;

$blk .= $lines[$line] . "\n";

$len = length($blk);

$line++;

last;

}

# Bail if there is no further context.

#warn "CSB: blk<$blk> off<$off> len<$len>\n";

if ($off >= $len) {

last;

}

if ($level == 0 && substr($blk, $off) =~ /^.\s*#\s*define/) {

$level++;

$type = '#';

}

}

$p = $c;

$c = substr($blk, $off, 1);

$remainder = substr($blk, $off);

#warn "CSB: c<$c> type<$type> level<$level> remainder<$remainder> coff_set<$coff_set>\n";

# Handle nested #if/#else.

if ($remainder =~ /^#\s*(?:ifndef|ifdef|if)\s/) {

push(@stack, [ $type, $level ]);

} elsif ($remainder =~ /^#\s*(?:else|elif)\b/) {

($type, $level) = @{$stack[$#stack - 1]};

} elsif ($remainder =~ /^#\s*endif\b/) {

($type, $level) = @{pop(@stack)};

}

# Statement ends at the ';' or a close '}' at the

# outermost level.

if ($level == 0 && $c eq ';') {

last;

}

# An else is really a conditional as long as its not else if

if ($level == 0 && $coff_set == 0 &&

(!defined($p) || $p =~ /(?:\s|\}|\+)/) &&

$remainder =~ /^(else)(?:\s|{)/ &&

$remainder !~ /^else\s+if\b/) {

$coff = $off + length($1) - 1;

$coff_set = 1;

#warn "CSB: mark coff<$coff> soff<$soff> 1<$1>\n";

#warn "[" . substr($blk, $soff, $coff - $soff + 1) . "]\n";

}

if (($type eq '' || $type eq '(') && $c eq '(') {

$level++;

$type = '(';

}

if ($type eq '(' && $c eq ')') {

$level--;

$type = ($level != 0)? '(' : '';

if ($level == 0 && $coff < $soff) {

$coff = $off;

$coff_set = 1;

#warn "CSB: mark coff<$coff>\n";

}

}

if (($type eq '' || $type eq '{') && $c eq '{') {

$level++;

$type = '{';

}

if ($type eq '{' && $c eq '}') {

$level--;

$type = ($level != 0)? '{' : '';

if ($level == 0) {

if (substr($blk, $off + 1, 1) eq ';') {

$off++;

}

last;

}

}

# Preprocessor commands end at the newline unless escaped.

if ($type eq '#' && $c eq "\n" && $p ne "\\") {

$level--;

$type = '';

$off++;

last;

}

$off++;

}

# We are truly at the end, so shuffle to the next line.

if ($off == $len) {

$loff = $len + 1;

$line++;

$remain--;

}

my $statement = substr($blk, $soff, $off - $soff + 1);

my $condition = substr($blk, $soff, $coff - $soff + 1);

#warn "STATEMENT<$statement>\n";

#warn "CONDITION<$condition>\n";

#print "coff<$coff> soff<$off> loff<$loff>\n";

return ($statement, $condition,

$line, $remain + 1, $off - $loff + 1, $level);

}

sub statement_lines {

my ($stmt) = @_;

# Strip the diff line prefixes and rip blank lines at start and end.

$stmt =~ s/(^|\n)./$1/g;

$stmt =~ s/^\s*//;

$stmt =~ s/\s*$//;

my @stmt_lines = ($stmt =~ /\n/g);

return $#stmt_lines + 2;

}

sub statement_rawlines {

my ($stmt) = @_;

my @stmt_lines = ($stmt =~ /\n/g);

return $#stmt_lines + 2;

}

sub statement_block_size {

my ($stmt) = @_;

$stmt =~ s/(^|\n)./$1/g;

$stmt =~ s/^\s*{//;

$stmt =~ s/}\s*$//;

$stmt =~ s/^\s*//;

$stmt =~ s/\s*$//;

my @stmt_lines = ($stmt =~ /\n/g);

my @stmt_statements = ($stmt =~ /;/g);

my $stmt_lines = $#stmt_lines + 2;

my $stmt_statements = $#stmt_statements + 1;

if ($stmt_lines > $stmt_statements) {

return $stmt_lines;

} else {

return $stmt_statements;

}

}

sub ctx_statement_full {

my ($linenr, $remain, $off) = @_;

my ($statement, $condition, $level);

my (@chunks);

# Grab the first conditional/block pair.

($statement, $condition, $linenr, $remain, $off, $level) =

ctx_statement_block($linenr, $remain, $off);

#print "F: c<$condition> s<$statement> remain<$remain>\n";

push(@chunks, [ $condition, $statement ]);

if (!($remain > 0 && $condition =~ /^\s*(?:\n[+-])?\s*(?:if|else|do)\b/s)) {

return ($level, $linenr, @chunks);

}

# Pull in the following conditional/block pairs and see if they

# could continue the statement.

for (;;) {

($statement, $condition, $linenr, $remain, $off, $level) =

ctx_statement_block($linenr, $remain, $off);

#print "C: c<$condition> s<$statement> remain<$remain>\n";

last if (!($remain > 0 && $condition =~ /^(?:\s*\n[+-])*\s*(?:else|do)\b/s));

#print "C: push\n";

push(@chunks, [ $condition, $statement ]);

}

return ($level, $linenr, @chunks);

}

sub ctx_block_get {

my ($linenr, $remain, $outer, $open, $close, $off) = @_;

my $line;

my $start = $linenr - 1;

my $blk = '';

my @o;

my @c;

my @res = ();

my $level = 0;

my @stack = ($level);

for ($line = $start; $remain > 0; $line++) {

next if ($rawlines[$line] =~ /^-/);

$remain--;

$blk .= $rawlines[$line];

# Handle nested #if/#else.

if ($lines[$line] =~ /^.\s*#\s*(?:ifndef|ifdef|if)\s/) {

push(@stack, $level);

} elsif ($lines[$line] =~ /^.\s*#\s*(?:else|elif)\b/) {

$level = $stack[$#stack - 1];

} elsif ($lines[$line] =~ /^.\s*#\s*endif\b/) {

$level = pop(@stack);

}

foreach my $c (split(//, $lines[$line])) {

##print "C<$c>L<$level><$open$close>O<$off>\n";

if ($off > 0) {

$off--;

next;

}

if ($c eq $close && $level > 0) {

$level--;

last if ($level == 0);

} elsif ($c eq $open) {

$level++;

}

}

if (!$outer || $level <= 1) {

push(@res, $rawlines[$line]);

}

last if ($level == 0);

}

return ($level, @res);

}

sub ctx_block_outer {

my ($linenr, $remain) = @_;

my ($level, @r) = ctx_block_get($linenr, $remain, 1, '{', '}', 0);

return @r;

}

sub ctx_block {

my ($linenr, $remain) = @_;

my ($level, @r) = ctx_block_get($linenr, $remain, 0, '{', '}', 0);

return @r;

}

sub ctx_statement {

my ($linenr, $remain, $off) = @_;

my ($level, @r) = ctx_block_get($linenr, $remain, 0, '(', ')', $off);

return @r;

}

sub ctx_block_level {

my ($linenr, $remain) = @_;

return ctx_block_get($linenr, $remain, 0, '{', '}', 0);

}

sub ctx_statement_level {

my ($linenr, $remain, $off) = @_;

return ctx_block_get($linenr, $remain, 0, '(', ')', $off);

}

sub ctx_locate_comment {

my ($first_line, $end_line) = @_;

# Catch a comment on the end of the line itself.

my ($current_comment) = ($rawlines[$end_line - 1] =~ m@.*(/\*.*\*/)\s*(?:\\\s*)?$@);

return $current_comment if (defined $current_comment);

# Look through the context and try and figure out if there is a

# comment.

my $in_comment = 0;

$current_comment = '';

for (my $linenr = $first_line; $linenr < $end_line; $linenr++) {

my $line = $rawlines[$linenr - 1];

#warn " $line\n";

if ($linenr == $first_line and $line =~ m@^.\s*\*@) {

$in_comment = 1;

}

if ($line =~ m@/\*@) {

$in_comment = 1;

}

if (!$in_comment && $current_comment ne '') {

$current_comment = '';

}

$current_comment .= $line . "\n" if ($in_comment);

if ($line =~ m@\*/@) {

$in_comment = 0;

}

}

chomp($current_comment);

return($current_comment);

}

sub ctx_has_comment {

my ($first_line, $end_line) = @_;

my $cmt = ctx_locate_comment($first_line, $end_line);

##print "LINE: $rawlines[$end_line - 1 ]\n";

##print "CMMT: $cmt\n";

return ($cmt ne '');

}

sub raw_line {

my ($linenr, $cnt) = @_;

my $offset = $linenr - 1;

$cnt++;

my $line;

while ($cnt) {

$line = $rawlines[$offset++];

next if (defined($line) && $line =~ /^-/);

$cnt--;

}

return $line;

}

sub cat_vet {

my ($vet) = @_;

my ($res, $coded);

$res = '';

while ($vet =~ /([^[:cntrl:]]*)([[:cntrl:]]|$)/g) {

$res .= $1;

if ($2 ne '') {

$coded = sprintf("^%c", unpack('C', $2) + 64);

$res .= $coded;

}

}

$res =~ s/$/\$/;