view release on metacpan or  search on metacpan

lib/Hardware/Vhdl/Automake/PreProcessor/Cish.pm  view on Meta::CPAN

        if (defined $state->{endat}) { $rem = $state->{endat} - tell($state->{fhi}) } # REMainding bytes we are allowed to read from the file
        if ( $state->{$bufname} =~ m/^(.*?(\015\012?|\012\015?))(.*)$/s ) {
            $state->{line}     = $1;
            $state->{$bufname} = $3;
        } elsif ( exists $state->{fhi} && !eof $state->{fhi} && (!defined $rem || ($rem > 0))) {
            local $/ = \$file_slurp_limit;
            if (defined $rem && $file_slurp_limit > $rem) { $/ = \$rem }
            $state->{$bufname} .= readline $state->{fhi};
            redo GET_LINE;
        } else {
            $state->{line}     = $state->{$bufname};
            $state->{$bufname} = '';
        }
    }
    $state->{line} = undef if $state->{line} eq '';
}

sub macro_define {
    my ($self, $macname, $macdef) = @_;
    my $perm  = $self->[0];
    $macdef = '' if !defined $macdef;
    if (exists $perm->{macros}{$macname}) {
        carp "Macro '$macname', defined at $perm->{macros}{$macname}{defined_in} line $perm->{macros}{$macname}{linenum}, was redefined";
    }
    $perm->{macros}{$macname} = { search => $macname, replace => $macdef, defined_in => $self->[-1]{source}, defined_line => $self->[-1]{linenum} };
    $self->update_macro_re;
}

sub macro_define_func {
    my ($self, $macname, $fargs, $macdef) = @_;
    $fargs =~ s/\s+//g;
    my @args = split(',', $fargs);
    my $arg_re = join '|', @args;
    #print "# macro function define: name='$macname', arg re='$arg_re', definition='$macdef'\n";
    $self->[0]{macros}{$macname.'('.scalar(@args)} = {
        search => $macname.'(',
        arg_re => qr/^(.*?)\b($arg_re)\b(.*)$/s,
        arg_index => { map { $args[$_] => $_ } 0..$#args },
        replace => $macdef,
        defined_in => $self->[-1]{source},
        defined_line => $self->[-1]{linenum}
      };
    $self->update_macro_re;
}

sub macro_undefine {
    my ($self, $macname) = @_;
    my $perm  = $self->[0];
    delete $perm->{macros}{$macname};
    $self->update_macro_re;
}

sub macro_undefine_func {
    my ($self, $macname, $args) = @_;
    print "# macro function undef: name='$macname', args='$args'\n";
    my @args = split(',', $args);
    delete $self->[0]{macros}{$macname.'('.scalar(@args)};
    $self->update_macro_re;
}

sub update_macro_re {
    my $perm  = shift->[0];
    my @macnames;
    my %macfuncnames;
    for my $search (map { $perm->{macros}{$_}{search} } keys %{$perm->{macros}}) {
        if (substr($search, -1) eq '(') {
            $macfuncnames{quotemeta($search)} = undef;
        } else {
            push @macnames, $search."\\b";
        }
    }
    my $macro_re = join '|', @macnames, keys %macfuncnames;
    #print "# macro regexp = /^(.*?)\\b($macro_re)(.*)\$/s\n";
    $perm->{macro_re} = qr/^ (.*?) ( " | \b(?:$macro_re) ) (.*) $/xs;
}

sub macro_replace {
    # do macro expansion on the non-quoted parts of $state->{line}
    my $self  = shift;
    my $perm  = $self->[0];
    my $state = $self->[-1];
    my $out = $self->_macro_replace_string($state->{line}, []);
    #~ if ( $out =~ m/^(.*?(\015\012?|\012\015?))(.*)$/s ) {
        #~ # deal with multi-line output from macro replacement
        #~ # TBD: doesn't this mean that lines after the first one get processed more than once?
        #~ $state->{line} = $1;
        #~ $perm->{ungot} = $3;
    #~ } else 
    {
        $state->{line} = $out;
    }
}

sub _extract_args {
    my ($self, $line) = @_;
    # Looks for a comma-separated list of args, followed by a ')'.  If found, return the stuff after the ')' and the list of args
    #  if no closing bracket found, returns $line only.
    # Currently needs to find the closing bracket on the current line
    my $in=$line; # text yet to be processed: we nibble this from the left
    my $out=''; # accumulator for bits that have been nibbled and may be added to argument list
    my $bd=0; # bracket depth
    my @args; # arguments found so far
    #print "#> in = '$in'\n";                
    while ($in =~ m/^ (.*?) ( [\(\)\",] ) (.*) $/xms) {
        $out .= $1; # prematch
        my $g = $2; # significant char: bracket, quote or comma
        $in = $3; # postmatch
        if ($g eq ',') {
            if ($bd==0) {
                # a comma, not inside a bracket: what we've found before this must be an argument
                push @args, $out;
                $out = '';
            } else {
                # a comma, from inside a bracket: just add it to the current argument string
                $out .= $g;
            }
        } elsif ($g eq ')') {
            if ($bd==0) {
                # a closing bracket, not inside a bracket: must be the end of the argument list
                return $in, @args, $out;
            } else {