I'm writing an image gallery tool for public consumption, and public consumption means some amount of configurability. For that configurability, I want first to provide a text file format, and in the long run provide a fancy GUI. That way, I get results fast, but in the long run also enable the users to configure the program to their needs.

As the configuration needs to work with both, the file and the GUI, the information about what items can be configured needs to be available as a data structure. For the text file, I want some DSLish format first, because that appeals to me, and I can use Perls parser:

    collect '//server/corion/images/';
    output '/home/corion/imagestream/output';
    size 160;
    size 640;
    exclude_tag 'private';
    prefer '.svg' => '.jpg';
    prefer '.svg' => '.png';
    prefer '.cr2' => '.jpg';

[download]

This is "self-explaining" Perl code, and it works quite well with a small set of predefined subroutines with prototypes:

    sub collect($) {
        push @image_directories, @_;
    };
    sub size($) {
        push @image_sizes, @_;
    };
    sub prefer($$) {
        push @prefer_format, [@_];
    };
    ...

[download]

Of course, the error messages are not ideal for the end user, and in the long run, I'll replace the text parser with something like Regexp::Grammar or Parse::YAPP, or even a new format like Config::GitLike, but for a first implementation, it works well and even allows for fancy stuff like using values from the environment ($ENV{HOME}) or shell subcommands (`cat tags`).

Except for one thing - that code does not rely on my data structure for the configuration items. So in reality, I should generate collect from this data structure:

    my $spec = {
      collect => {
        name => 'collect',
        arg_count => 1,
        desc => 'A directory from which to collect images',
      },
      prefer => {
        name => 'prefer',
        arg_count => 2,
        desc => 'Prefer this image format over files with the same nam
+e in other formats',
      },
    # ...
    };

[download]

Now, the question was: How could I dynamically install my subroutines, and preferrably in a way that didn't leave traces?

Installing the subroutines from the data was fairly easy:

    my %handler;
    for my $item (values %$spec) {
        my $n = $item->{name};
        my $fetch;
        $result->{$n} = [];
        if (0 == $item->{arg_count}) {
            $fetch = sub() { push @{ $result->{$n}}, 1; };
        } elsif (1 == $item->{arg_count}) {
            $fetch = sub($) { push @{ $result->{$n} }, @_; };
        } elsif (2 == $item->{arg_count}) {
            $fetch = sub($$) { push @{ $result->{$n} }, [@_]; };
        } else {
            $fetch = sub($;) { push @{ $result->{$n}}, [@_]; };
        };
        $handler{$n} = $fetch;
    };

    # Install the subroutines
    for (keys %handler) {
        no strict 'refs';
        *{$_} = $handler{ $_ };
    };
    
    # "execute" the config:
    my $cfg_str = join ";\n", 
                     "package " . __PACKAGE__,
                     "#line $config_source#1",
                     "$config_data",
                     "1";
    #warn $cfg_str;
        
    my $ok = eval $cfg_str;
    my $err = $@;

    if ($ok) {
        return $result
    } else {
        warn $err;
        return
    };

[download]

... but this leaves the unsightly clutter of the temporary handlers around, which irked me.

There is an easy way in Perl to clean up things when you go away, local. But local works only within a single scope, so using it within a loop makes things hard.

I thought about doing the localization manually, for example by using Scope::Guard (or Guard): 

use Scope::Guard qw(guard);
{ 
    my @guards;
    for (keys %handler) {
        # Save the old state:
        my($k,$p) = ($_,\&$_);
        push @guards, guard { 
            # restore the old state
            *$k = $p;
        };
        # Install our new handler
        *$_ = \&$handler{$_};
    }
    
    # "execute" the config
    # ...
}
# Scope::Guard executes our guard blocks here

[download]

... but it struck me as inelegant to have to do the restoral myself.

I tried a loopless approach, very much like in Local $$_?, but that didn't work at all:

    local @{My::App}{keys %handler} = values %handler;
    # Can't modify glob elem in local at ...

[download]

... and doing this in a loop defies the purpose of local in a grand way:

    for my $n (keys %handler) {
        local *$n = $handler{ $n };
    }
    # no handlers defined here anymore

[download]

So, to achieve my goal using local, I would need a loop that didn't introduce another scope. Which was easy when I found it, but it used goto:

    my ($ok,$err);
    my $cfg_str = join ";\n", 
                     "package " . __PACKAGE__,
                     "#line $config_source#1",
                     "$config_data",
                     "1";
    my @handlers = keys %handler;
    {
        no strict 'refs';
        
        # We don't want to introduce another scope, as that will
        # negate the effect of the local:
        NEXT:
            my $n = shift @handlers;
            local *{$n} = $handler{ $n };
            goto NEXT
                if @handlers;
                
        $ok = eval $cfg_str;
        $err = $@;
    }

    if ($ok) {
        return $result
    } else {
        warn $err;
        return
    };

[download]

Now, that's at least something that I couldn't have done without having goto available to me. But should I really stay with this approach instead of writing a "proper" parser in Perl instead of reusing the Perl parser, then I should really use the approach that ambrus proposed: The Scope::Guard-based approach, hidden away in another subroutine:

    ...
    {
        my $guard = local_install_subs \%handler;
        $ok = eval $cfg_str;
        $err = $@;
    }
    ...

[download]

When discussing this in the CB, I was reminded of Scope::Upper, which allows you to localize things one (or more) scopes upwards from your current scope. Reading the SYNOPSIS of Scope::Upper makes my head hurt because it also deals with jumping out of scopes and into other places, but I should also investigate it.

Replies are listed 'Best First'.
Re: A useful use of goto
by The Perlman (Scribe) on Apr 11, 2010 at 21:32 UTC
    Sorry, I don't understand your need for localization.

    Please explain if you want your DSL handlers to disappear why don't you simply use a temporary namespace which you destroy afterwards?

    You're already adding a package to $cfg_str, just call it TMP_CONFIG1234!

    If you're still afraid you can still delete all references to this package from main's stash afterwards...

[reply]
[d/l]

      Yes, sticking everything into a temporary namespace would have worked too, that approach did not occur to me at all.

[reply]
        You don't even need a temporary namespace, just call it something like __PACKAGE__::Config and you can reuse it on demand.

        Anyway thank you, the pattern of using goto for a scopeless loop is worth to be mentioned! 8)

[reply]
[d/l]
[select]
Re: A useful use of goto
by jwkrahn (Abbot) on Apr 11, 2010 at 21:46 UTC 
        {
        no strict 'refs';
        
        # We don't want to introduce another scope, as that will
        # negate the effect of the local:
        NEXT:
            my $n = shift @handlers;
            local *{$n} = $handler{ $n };
            goto NEXT
                if @handlers;

        $ok = eval $cfg_str;
        $err = $@;
    }

    [download]

    The code is inside a loop (yes it is) so there is no need to use goto: 

        NEXT: {
        no strict 'refs';
        
        # We don't want to introduce another scope, as that will
        # negate the effect of the local:
            my $n = shift @handlers;
            local *{$n} = $handler{ $n };
            redo NEXT
                if @handlers;

        $ok = eval $cfg_str;
        $err = $@;
    }

    [download]

    Or perhaps: 

        {
        no strict 'refs';
        
        # We don't want to introduce another scope, as that will
        # negate the effect of the local:
        NEXT: {
            my $n = shift @handlers;
            local *{$n} = $handler{ $n };
            redo NEXT
                if @handlers;
        }
        $ok = eval $cfg_str;
        $err = $@;
    }

    [download]
[reply]
[d/l]
[select]

      Ah yes, I forgot about redo. But your second approach introduces another block and thus won't work:

      my %handler = (
    hello => sub() { print "hello world\n" },
);

my ($ok,$err);
my @handlers = keys %handler;
my $cfg_str = 'hello();';
{
    no strict 'refs';
    
    # We don't want to introduce another scope, as that will
    # negate the effect of the local:
    NEXT: {
        my $n = shift @handlers;
        local *{$n} = $handler{ $n };
        redo NEXT
            if @handlers;
    }
    $ok = eval $cfg_str;
    $err = $@;
}

warn $err if $err;
__END__
Undefined subroutine &main::hello called at (eval 1) line 1.

      [download]
[reply]
[d/l]
      > The code is inside a loop (yes it is) so there is no need to use goto:

      Are you sure? IMHO each redo means leaving the scope and "delocalizes" all variables so far. 

      perl -e '
NEXT: {
  local $a.=$x++;
  redo NEXT if $x<10;
  print $a;             # prints only 9
}
'

      [download]
      BTW: no need for a NEXT label, redo alone would do! : )

      UPDATE: I think you're wrong! 

      $x=0;
{
 NEXT: 
 { 
  $x==0 ? (local $a="A") : (local $b="B");
  redo NEXT if $x++<1;
  print $a,$b;             
 }
}

      [download]
      only prints "B"! BUT 
      $x=0;
{
 NEXT: 
  $x==0 ? (local $a="A") : (local $b="B");
  goto NEXT if $x++<1;
  print $a,$b;             
}

      [download]
      prints "AB"
[reply]
[d/l]
[select]
      > Or perhaps:

      nope, shouldn't work, each block in perl has its own scope.

[reply]
Re: A useful use of goto
by Anonymous Monk on Apr 12, 2010 at 00:42 UTC
[reply]

      I think in the end result what I want to accomplish is very similar to what these modules provide. The way they go around achieving it, by source-filtering their input, is not what I want to try, because of the usual problems with source filters.

[reply]
Re: A useful use of goto
by JavaFan (Canon) on Apr 12, 2010 at 08:42 UTC
    Now, that's at least something that I couldn't have done without having goto available to me.
    Statement modifiers don't introduce a scope either, so I don't see why you couldn't have written: 
    local *{$_} = $handler{$_} for keys %handler;

    [download]
    Note that I don't mind uses of goto or that I think you should have written your code using my line. It's just the "couldn't have done without goto" that made me curious.
[reply]
[d/l]

      I thought so too, but at least this sample program fails for me:

      #!perl -w
use strict;
use Data::Dumper;
$Data::Dumper::Sortkeys = 1;

my %handler = (
    hello => sub() { print "hello world\n" },
);

my ($ok,$err);
my @handlers = keys %handler;
my $cfg_str = 'test(); hello();';
{
    no strict 'refs';
    
    # We don't want to introduce another scope, as that will
    # negate the effect of the local:
    
    warn Dumper \%{main::};

    # A first my own declaration
    local *{test} = sub { print "This is a test\n"; };
    local *{$_} = $handler{ $_ }
        for keys %handler;

    warn Dumper \%{main::};

    print '$handler{hello} ', $handler{ hello },"\n";
    print '*::{hello} [',*::{ hello } || '<none>',"]\n";

    $ok = eval $cfg_str;
    $err = $@;
}

warn $err if $err;
__END__

Name "main::test" used only once: possible typo at tmp.pl line 22.
$VAR1 = {
          ' => *{':'},
          '&#9788;' => *{'::&#9788;'},
          '&#8597;' => *{'::&#8597;'},
          '&#8616;ARNING_BITS' => *{'::&#8616;ARNING_BITS'},
          '&#8593;' => *{'::&#8593;'},
          '!' => *{'::!'},
          '"' => *{'::"'},
          '$' => *{'::$'},
          '+' => *{'::+'},
          '-' => *{'::-'},
          '/' => *{'::/'},
          '0' => *{'::0'},
          '1' => *{'::1'},
          '<none>::' => *{'::<none>::'},
          '@' => *{'::@'},
          'ARGV' => *::ARGV,
          'ActivePerl::' => *{'::ActivePerl::'},
          'B::' => *{'::B::'},
          'BEGIN' => *::BEGIN,
          'CORE::' => *{'::CORE::'},
          'Carp::' => *{'::Carp::'},
          'Config::' => *{'::Config::'},
          'DATA' => *::DATA,
          'DB::' => *{'::DB::'},
          'Data::' => *{'::Data::'},
          'Dumper' => *::Dumper,
          'DynaLoader::' => *{'::DynaLoader::'},
          'ENV' => *::ENV,
          'Exporter::' => *{'::Exporter::'},
          'INC' => *::INC,
          'IO::' => *{'::IO::'},
          'Internals::' => *{'::Internals::'},
          'PerlIO::' => *{'::PerlIO::'},
          'Regexp::' => *{'::Regexp::'},
          'SIG' => *::SIG,
          'STDERR' => *::STDERR,
          'STDIN' => *::STDIN,
          'STDOUT' => *::STDOUT,
          'Scalar::' => *{'::Scalar::'},
          'UNIVERSAL::' => *{'::UNIVERSAL::'},
          'Win32::' => *{'::Win32::'},
          'XSLoader::' => *{'::XSLoader::'},
          '_' => *::_,
          '_<..\\activeperl.c' => *{'::_<..\\activeperl.c'},
          '_<..\\perlio.c' => *{'::_<..\\perlio.c'},
          '_<..\\universal.c' => *{'::_<..\\universal.c'},
          '_<..\\xsutils.c' => *{'::_<..\\xsutils.c'},
          '_<.\\win32.c' => *{'::_<.\\win32.c'},
          '_<C:/Program Files/Perl/lib/auto/Data/Dumper/Dumper.dll' =>
+ *{'::_<C:/Program Files/Perl/lib/auto/Data/Dumper/Dumper.dll'
},
          '_<Dumper.c' => *{'::_<Dumper.c'},
          '_<dl_win32.c' => *{'::_<dl_win32.c'},
          '_<perllib.c' => *{'::_<perllib.c'},
          '__ANON__' => *::__ANON__,
          'attributes::' => *{'::attributes::'},
          'bytes::' => *{'::bytes::'},
          'main::' => *{'::main::'},
          'overload::' => *{'::overload::'},
          'stderr' => *::stderr,
          'stdin' => *::stdin,
          'stdout' => *::stdout,
          'strict::' => *{'::strict::'},
          'test' => *::test,
          'utf8::' => *{'::utf8::'},
          'warnings::' => *{'::warnings::'}
        };
$VAR1 = {
          ' => *{':'},
          '&#9788;' => *{'::&#9788;'},
          '&#8597;' => *{'::&#8597;'},
          '&#8616;ARNING_BITS' => *{'::&#8616;ARNING_BITS'},
          '&#8593;' => *{'::&#8593;'},
          '!' => *{'::!'},
          '"' => *{'::"'},
          '$' => *{'::$'},
          '+' => *{'::+'},
          '-' => *{'::-'},
          '/' => *{'::/'},
          '0' => *{'::0'},
          '1' => *{'::1'},
          '<none>::' => *{'::<none>::'},
          '@' => *{'::@'},
          'ARGV' => *::ARGV,
          'ActivePerl::' => *{'::ActivePerl::'},
          'B::' => *{'::B::'},
          'BEGIN' => *::BEGIN,
          'CORE::' => *{'::CORE::'},
          'Carp::' => *{'::Carp::'},
          'Config::' => *{'::Config::'},
          'DATA' => *::DATA,
          'DB::' => *{'::DB::'},
          'Data::' => *{'::Data::'},
          'Dumper' => *::Dumper,
          'DynaLoader::' => *{'::DynaLoader::'},
          'ENV' => *::ENV,
          'Exporter::' => *{'::Exporter::'},
          'INC' => *::INC,
          'IO::' => *{'::IO::'},
          'Internals::' => *{'::Internals::'},
          'PerlIO::' => *{'::PerlIO::'},
          'Regexp::' => *{'::Regexp::'},
          'SIG' => *::SIG,
          'STDERR' => *::STDERR,
          'STDIN' => *::STDIN,
          'STDOUT' => *::STDOUT,
          'Scalar::' => *{'::Scalar::'},
          'UNIVERSAL::' => *{'::UNIVERSAL::'},
          'Win32::' => *{'::Win32::'},
          'XSLoader::' => *{'::XSLoader::'},
          '_' => *::_,
          '_<..\\activeperl.c' => *{'::_<..\\activeperl.c'},
          '_<..\\perlio.c' => *{'::_<..\\perlio.c'},
          '_<..\\universal.c' => *{'::_<..\\universal.c'},
          '_<..\\xsutils.c' => *{'::_<..\\xsutils.c'},
          '_<.\\win32.c' => *{'::_<.\\win32.c'},
          '_<C:/Program Files/Perl/lib/auto/Data/Dumper/Dumper.dll' =>
+ *{'::_<C:/Program Files/Perl/lib/auto/Data/Dumper/Dumper.dll'
},
          '_<Dumper.c' => *{'::_<Dumper.c'},
          '_<dl_win32.c' => *{'::_<dl_win32.c'},
          '_<perllib.c' => *{'::_<perllib.c'},
          '__ANON__' => *::__ANON__,
          'attributes::' => *{'::attributes::'},
          'bytes::' => *{'::bytes::'},
          'hello' => *::hello,
          'main::' => *{'::main::'},
          'overload::' => *{'::overload::'},
          'sort::' => *{'::sort::'},
          'stderr' => *::stderr,
          'stdin' => *::stdin,
          'stdout' => *::stdout,
          'strict::' => *{'::strict::'},
          'test' => *::test,
          'utf8::' => *{'::utf8::'},
          'warnings::' => *{'::warnings::'}
        };
$handler{hello} CODE(0x212e788)
*::{hello} [<none>]
This is a test
Undefined subroutine &main::hello called at (eval 1) line 1.

      [download]

      ... and it fails in a most weird way, as *::hello gets a slot after the loop, but it can't find hello() while it can find test().

[reply]
[d/l]
[select]
        It seems that while the if modifier doesn't introduce a scope, the for modifier does (probably to localize $_). So, my suggestion isn't going to work. :-(.
[reply]
[d/l]
Re: A useful use of goto
by BenGoldberg (Sexton) on Apr 22, 2014 at 02:07 UTC
    There are a few more solutions that you could have used.

    First and foremost, use a Safe. For example:

       use Safe;
   my $config = Safe->new;
   *{ $config->varglob($_) } = $handler{$_}
      for keys %handler;
   $ok = $config->reval( $cfg_str );
   # Or: $ok = $config->rdo( $config_source );
   $err = $@;

    [download]
    When you are done, you can simply throw away the Safe object, and everything is totally cleaned up.

    Secondly, (if using regular string eval, and not a Safe) you could have added the following to your $cfg_str:

    join ";\n", map "local *$_ = \$handler{$_}", keys %handler;

    [download]
    That would have cause the local to be undone the moment the string eval finished running.

    Thirdly, you could have used recursion:

       local *handler_localizer = sub {
      if( my $name = each %handler ) {
         no strict 'refs';
         local *{$name} = $handler{$name};
         handler_localizer();
      } else {
         $ok = eval $cfg_str;
         $err = $@;
      }
   };

    [download]
    But this is silly, when a Safe is so much simpler.
[reply]
[d/l]
[select]

Back to Meditations