view release on metacpan or  search on metacpan

lib/App/Mowyw.pm  view on Meta::CPAN

    my $tokens = shift;
    my $meta = shift;
#    print Dumper $meta;
    my $key = strip_ws(p_expect($tokens, "UNMATCHED", $meta));
    my @words = split /\s+/, $key;
    p_expect($tokens, "TAG_END", $meta);
    my $menu_fn = shift @words;
#    print "\nMenu: '$menu_fn'\n";
    $menu_fn = get_include_filename('menu', $menu_fn, $meta->{FILES}->[-1]);
#    print "Menu after frobbing: '$menu_fn'\n";

    my $m = my_dclone($meta);
    push @{$m->{ITEMS}}, @words;
    unshift @{$m->{FILES}}, $menu_fn;
    return parse_file($menu_fn, $m);
}

# parse sub: parse an 'option' statement
sub p_option {
    my $tokens = shift;
    my $meta = shift;
    my $key = strip_ws(p_expect($tokens, "UNMATCHED", $meta));
    my @words = split /\s+/, $key;
    my $option_key = shift @words;
    my $option_val = join " ", @words;
    $meta->{OPTIONS}->{$option_key} = $option_val;
    p_expect($tokens, "TAG_END", $meta);
    return "";
}

#parse sub: parse an "item" statement
sub p_item {
    my $tokens = shift;
    my $meta = shift;
    my $content = p_expect($tokens, "UNMATCHED", $meta);
    $content =~ s/^\s+//;
    $content =~ m/^(\S+)/;
    my $key = $1;
    $content =~ s/^\S+//;

    my $m = my_dclone($meta);
#   print Data::Dumper->Dump([$m]);
    if ($meta->{ITEMS}->[0] and $meta->{ITEMS}->[0] eq $key){
        shift @{$m->{ITEMS}};
        $m->{CURRENT_ITEM} = $key;

    } else {
        $m->{ITEMS} = [];
        $m->{CURRENT_ITEM} = undef;
    }
    $m->{INSIDE_ITEM} = 1;
    my $str = $content . parse_tokens($tokens, $m);
    p_expect($tokens, "TAG_END", $meta);
    return $str;

}

sub p_bind {
    my ($tokens, $meta) = @_;
    my $contents = strip_ws(slurp_upto_token($tokens, 'TAG_END', $meta));
    my ($var, $rest) = split m/\s+/, $contents, 2;
    my $string = qr{(
         '[^'\\]*(?>\\.[^'\\]*)*'
        |"[^"\\]*(?>\\.[^"\\]*)*'
        |[^"']\S*
    )}x;
    my %options = parse_hash($rest, 'bind', $meta);

    if ($options{file}){
        $options{file} = get_include_filename('include', $options{file}, $meta->{FILES}->[-1]);
    }
    $meta->{VARS}{$var} = App::Mowyw::Datasource->new(\%options);

    return '';
}

sub p_for {
    my ($tokens, $meta) = @_;
    my $contents = strip_ws(slurp_upto_token($tokens, 'TAG_END', $meta));
    my ($iter, $in, $datasource) = split m/\s+/, $contents;
    if (!defined $datasource || lc $in ne 'in' ){
        parse_error(
                q{Can't parse for statement. Syntax is [% for iterator_var in datasource %] ... [% endfor %]},
                $meta->{FILES},
                $tokens->[0],
        );
    }
    my $ds = $meta->{VARS}{$datasource};
    if (!$ds || !blessed($ds)){
        confess "'$datasource' is not defined or not a valid data source\n";
    }

    my @bck_tokens = @$tokens;
    my $str = '';
    $ds->reset();
    while (!$ds->is_exhausted){
        local $meta->{VARS}{$iter} = $ds->get();
        local $meta->{PARSE_UPTO} = 'endfor';
        @$tokens = @bck_tokens;
#        print "Iterating over '$datasource'\n";
        $str .= parse_tokens($tokens, $meta);
        $ds->next();
    }
    return $str;
}

sub p_ifvar {
    my ($tokens, $meta) = @_;
    my $contents = strip_ws(slurp_upto_token($tokens, 'TAG_END', $meta));
    if ($contents =~ m/\s/){
        parse_error(
            q{Parse error in 'ifvar' tag. Syntax is [% ifvar variable %] .. [% endifvar %]},
            $meta->{FILES},
            $tokens->[0],
        );
    }
    my $c = do {
        local $meta->{NO_VAR_WARN} = 1;
        resolve_var($contents, $meta);
    };
    local $meta->{PARSE_UPTO} = 'endifvar';
    if (defined $c){
#        warn "Variable '$contents' is defined\n";
        return parse_tokens($tokens, $meta); 
    } else {
#        warn "Variable '$contents' is NOT defined\n";
        local $meta->{NO_VAR_WARN} = 1;
        parse_tokens($tokens, $meta); 
        return '';
    }
}

sub p_verbatim {
    my $tokens = shift;
    my $meta = shift;
    my $str = "";
    my $key = strip_ws(slurp_upto_token($tokens, 'TAG_END', $meta));
#    print Dumper $tokens;
    while (@$tokens){
        if (    $tokens->[0]->[0] eq "TAG_START" 
            and $tokens->[1]->[0] eq "KEYWORD"
            and $tokens->[1]->[1] eq "endverbatim"
            and $tokens->[2]->[1] =~ m/\s*\Q$key\E\s*/
            and $tokens->[3]->[0] eq "TAG_END"){

            # found end of verbatim section
            shift @$tokens for 1 .. 4;
            return $str;
        } else {
            $str .= $tokens->[0]->[1]; 
            shift @$tokens;
        }
    }
    die "[[[verbatim $key]]] opened but not closed until end of file\n";
}

sub p_comment {
    my $tokens = shift;
    my $meta = shift;
    slurp_upto_token($tokens, 'TAG_END', $meta);
    return "";
}


sub resolve_var {
    my ($name, $meta) = @_;
    if ($name =~ m/\./){
        my @parts = split m/\./, $name;
        my $var = $meta->{VARS};
        for (@parts){
            if (!defined $var || !ref $var || reftype($var) ne 'HASH'){
                unless ($meta->{NO_VAR_WARN}){
                    warn "\nCan't dereference '$name' at level '$_': not defined or not a hash\n";
                }
                return undef;
            }
            $var = $var->{$_};
        }
        return $var;
    }
    if (exists $meta->{VARS}->{$name}){
        return $meta->{VARS}->{$name};
    } else {
        unless ($meta->{NO_VAR_WARN} || $config{quiet}){
            print STDERR "Trying to access variable '$name' which is not defined\n";
        }
        return undef;
    }
}

sub encode_entities {
    my $str = shift;
    return '' unless defined $str;
    $str =~ s{&}{&}g;
    $str =~ s{<}{&lt;}g;
    $str =~ s{>}{&gt;}g;
    $str =~ s{"}{&quot;}g;
    return $str;
}

sub slurp_upto_token {
    my ($tokens, $expected_token, $meta) = @_;
    my $str = '';
    while (@$tokens && $tokens->[0][0] ne $expected_token){
        $str .= $tokens->[0][1];
        shift @$tokens;
    }
    p_expect($tokens, $expected_token, $meta);
    return $str;
}

sub parse_hash {
    my ($str, $statement_name, $meta) = @_;
    return unless defined $str;

    my $del_string = qr{(
         '[^'\\]*(?>\\.[^'\\]*)*'
        |"[^"\\]*(?>\\.[^"\\]*)*'
        |[^"']\S*
    )}x;
    my %options;
    pos($str) = 0;
    while ($str =~ m/\G\s*(\w+):$del_string\s*/gc){
        my $key = $1;
        my $val = $2;
        $val =~ s/^['"]//;
        $val =~ s/['"]$//;
        $val =~ s{\\(.)}{$1}g;

lib/App/Mowyw.pm  view on Meta::CPAN

    # becase DBI objects from App::Mowyw::Datasource::DBI hold code refs.
    # so we don't clone blessed objects at all, but pass a reference instead.
    my $meta = shift;
    my %result;
    for (keys %$meta){
        if ($_ eq 'VARS'){
            my %vs = %{$meta->{VARS}};
            for my $v (keys %vs){
                if (blessed $vs{$v}){
                    $result{VARS}{$v} = $vs{$v};
                } else {
                    $result{VARS}{$v} = ref $vs{$v} ? dclone($vs{$v}) : $vs{$v};
                }
            }
        } else {
            $result{$_} = ref $meta->{$_} ? dclone($meta->{$_}) : $meta->{$_};
        }
    }

    return \%result;
}

sub p_braces {
    my $tokens = shift;
    my $meta = shift;
    my $str = "";
    p_expect($tokens,"BRACES_START", $meta);
    if ($meta->{CURRENT_ITEM}){
#       print "using text inside braces\n";
        $str .= parse_tokens($tokens, $meta);
    } else {
        # discard the text between opening {{ and closing }} braces
#       print "discarding text inside braces\n";
        parse_tokens($tokens, $meta);
    }
    p_expect($tokens, "BRACES_END", $meta);
    return $str;
}

sub p_setvar {
    my $tokens = shift;
    my $meta = shift;
    my $str = "";
    while ($tokens->[0]->[0] ne "TAG_END"){
        $str .= $tokens->[0]->[1];
        shift @$tokens;
    }
    p_expect($tokens, "TAG_END", $meta);
    $str = strip_ws($str);
    $str =~ m#^(\S+)\s#;
    my $name = $1;
    my $value = $str;
    $value =~ s/^\S+\s+//;
    $meta->{VARS}->{$name} = $value;
    return "";
}

sub p_readvar {
    my ($tokens, $meta) = @_;
    my $str = strip_ws(slurp_upto_token($tokens, 'TAG_END', $meta));
    my ($name, $rest) = split m/\s+/, $str, 2;
    my %options = parse_hash($rest, 'readvar', $meta);
    my $c = resolve_var($name, $meta);

    if (defined $options{escape} && lc $options{escape} eq 'html'){
        return encode_entities($c);
    }
    return $c if defined $c;
    return '';
}

sub p_syntaxfile {
    my $tokens = shift;
    my $meta = shift;
    my $tag_content = shift @$tokens;
    $tag_content = strip_ws($tag_content->[1]);
    p_expect($tokens, "TAG_END", $meta);
    my @t = split m/\s+/, $tag_content;
    if (scalar @t != 2){
        parse_error(
            "Usage of syntaxfile tag: [[[syntaxfile <filename> <language>",
            $meta->{FILES},
            $tokens->[0],
        );
    }

}

sub p_syntax {
    my $tokens = shift;
    my $meta = shift;
    my $lang = shift @$tokens;
    $lang = strip_ws($lang->[1]);
    p_expect($tokens, "TAG_END", $meta);
    my $str = "";
    while ($tokens->[0] and  not ($tokens->[0]->[0] eq "TAG_START" and $tokens->[1]->[1] eq "endsyntax" and $tokens->[2]->[0] eq "TAG_END")){
        $str .= $tokens->[0]->[1];
        shift @$tokens;
    }
    p_expect($tokens, "TAG_START", $meta);
    p_expect($tokens, "KEYWORD", $meta);
    p_expect($tokens, "TAG_END", $meta);

    return do_hilight($str, $lang, $meta);
}

sub do_hilight {
    my ($str, $lang, $meta) = @_;
    if ($lang eq 'escape'){
        return encode_entities($str);
    }
    eval {
        no warnings "all";
        require Text::VimColor;
    };
    if ($@){
        # require was not successfull 
        print STDERR " Not syntax hilighting, Text::VimColor not found\n" unless $config{quiet};
        # encode at least some special chars "by hand"
        return encode_entities($str);
    } else {
        print STDERR "." unless $config{quiet};
        # any encoding will do if vim automatically detects it
        my $vim_encoding = 'utf-8';
        my $BOM = "\x{feff}";
        my $syn = Text::VimColor->new(
                filetype    => $lang,
                string      => encode($vim_encoding, $BOM . $str),
                );
        $str = decode($vim_encoding, $syn->html);
        $str =~ s/^$BOM//;
        return $str;
    }
}

# parse sub: expect a specific token, return its content or die if the
# expectation was not met.
sub p_expect {