in reply to Re^8: parse lisp style config
in thread parse lisp style config

package MyPairList; use strict; use warnings; use feature 'state'; use Data::Dumper; use List::Util qw(all none); use Exporter 'import'; our @EXPORT = qw(pair_list_parse); sub pair_list_parse { my $string = shift; my sub get_tokens { my $string = shift; my @tokens = $string =~ /([()]|[^()\s]+)/g; } my @tokens = get_tokens $string; my sub parse_list { state @tokens = @_; my @list; while (my $token = shift @tokens) { if ($token eq '(') { push @list, __SUB__->(); } elsif ($token eq ')') { return \@list; } else { push @list, $token; } } return \@list; } my $list = parse_list @tokens; my sub parse_nested_list { my ($list) = @_; my %hash; if (none {ref $_} @$list) { if (@$list == 1) { return $list->[0]; } elsif (@$list == 2) { return { $list->[0] => $list->[1] }; } else { return $list } } elsif (all {ref $_} @$list) { return [ map { __SUB__->($_) } @$list ]; } else { my ($key, $ref, @remain) = @$list; die 'wrong key ', Dumper $key if ref $key; die 'wrong value ', Dumper $ref unless ref $ref; die 'redundant value', Dumper \@remain if @remain; $hash{$key} = __SUB__->($ref); } return \%hash; } return parse_nested_list($list) } 1;
Last time I just add my to two subs do recusion, and die with 'undeined sub', now I replace it with __SUB__, still 'Undefined subroutine &MyPairList::__SUB__ called at /usr/local/bin/MyPairList.pm line 23, <> line 1.' It did not work.

Replies are listed 'Best First'.
Re^10: parse lisp style config
by hippo (Archbishop) on Nov 30, 2024 at 11:51 UTC

      Or use v5.16;.

        perl did not mention it's a feature, when using refaliasing without declare it got smarter. Now it's all good.
Re^10: parse lisp style config
by ikegami (Patriarch) on Nov 30, 2024 at 17:40 UTC

    You have this:

    my @tokens = get_tokens $string; my sub parse_list { state @tokens = @_; my @list; while (my $token = shift @tokens) { if ($token eq '(') { push @list, __SUB__->(); } elsif ($token eq ')') { return \@list; } else { push @list, $token; } } return \@list; } my $list = parse_list @tokens;

    Sometimes you pass tokens to it. Sometimes you don't. That's weird and confusing. Fixed:

    my @tokens = get_tokens $string; my sub parse_list { my @list; while (my $token = shift @tokens) { if ($token eq '(') { push @list, __SUB__->(); } elsif ($token eq ')') { return \@list; } else { push @list, $token; } } return \@list; } my $list = parse_list;

    The lack of error checking is disturbing. Fixed:

    my @tokens = get_tokens $string; my sub parse_list { my @list; while ( @tokens && $tokens[0] ne ")" ) { my $token = shift( @tokens ); if ( $token eq "(" ) { push @list, __SUB__->(); die( "Missing `)`" ) if !@token; my $token = shift( @tokens ); die( "Missing `)`" ) if $token ne ")"; } else { push @list, $token; } } return \@list; }; my $list = parse_list(); die( "Unexpected `$tokens[0]`" ) if @tokens;

    Without recursion:

    my @tokens = get_tokens $string; my sub parse_list { my @stack; push @stack, [ ]; while ( @tokens ) { my $token = shift( @tokens ) { if ( $token eq "(" ) { my $sublist = [ ]; push @{ $stack[ -1 ] }, $sublist; push @stack, $sublist; } elsif ( $token eq ")" ) { die( "Unexpected `)` ) if @stack == 1; pop( @stack ); } else { push @{ $stack[ -1 ] }, $token; } } die( "Missing `)` ) if @stack > 1; return $stack[ 0 ]; } my $list = parse_list(); die( "Unexpected `$tokens[0]`" ) if @tokens;
      add some check is good, and need to point at wrong line.
      package MyPairList; use strict; use warnings; use feature 'state'; use Data::Dumper; use List::Util qw(all none); use Exporter 'import'; use feature 'current_sub'; our @EXPORT = qw(pair_list_parse); sub pair_list_parse { my $string = shift; my sub get_tokens { my $string = shift; my @tokens = $string =~ /([()\n]|[^()\s]+)/g; } my @tokens = get_tokens $string; my sub check_tokens { my $line; my @line; for my $token (@tokens) { if ($token eq "\n") { $line++; my $left = scalar grep {$_ eq '('} @line; my $right = scalar grep {$_ eq ')'} @line; my $is_open = $line[-1] eq '('; my $is_all_right = $right && not $left; my $is_closed = $right == $left; die "config line $line wrong" unless ( $is_open or $is_all_ +right or $is_closed); @line = (); } else { push @line, $token } } } check_tokens; my sub parse_list { my @list; while (my $token = shift @tokens) { if ($token eq "\n") { next; } elsif ($token eq '(') { push @list, __SUB__->(); } elsif ($token eq ')') { return \@list; } else { push @list, $token; } } return \@list; } my $list = parse_list; my sub parse_nested_list { my ($list) = @_; my %hash; if (none {ref $_} @$list) { if (@$list == 1) { return $list->[0]; } elsif (@$list == 2) { return { $list->[0] => $list->[1] }; } else { return $list } } elsif (all {ref $_} @$list) { return [ map { __SUB__->($_) } @$list ]; } else { my ($key, $ref, @remain) = @$list; die 'wrong key ', Dumper $key if ref $key; die 'wrong value ', Dumper $ref unless ref $ref; die 'redundant value', Dumper \@remain if @remain; $hash{$key} = __SUB__->($ref); } return \%hash; } return parse_nested_list($list) } 1;
      Every line can only brankets closed if not open or pure ')'