Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number
 
PerlMonks  

Using a regex function from a hash

by perlNinny (Beadle)
on Aug 02, 2006 at 18:43 UTC ( [id://565288]=perlquestion: print w/replies, xml ) Need Help??

perlNinny has asked for the wisdom of the Perl Monks concerning the following question:

What I want is a function hash that when it finds a line with one thing in it, will work on that line with the function its associated with. See the code below for an example: 
#!/bin/perl

my @view = ("ignore","ignore","dont\\ignore\\this.vms","ignore");
my %functions_hash = ( '\.vms' => 's/\///');

foreach my $data (@views)
{
   while (($key, $value) = each %functions_hash)
   {
      if( $data =~ /$key/ )
      {
          $data =~ $value;
          print "data is now $data\n";
      }
   }
}

[download]

Replies are listed 'Best First'.
Re: Using a regex function from a hash
by Fletch (Bishop) on Aug 02, 2006 at 18:48 UTC

    Bad news: regexen and substitutions don't work that way.

    Good news: if use an anonymous sub instead you can do what you want. 

    my %functions = ( "\\.vms" => sub { my $t = shift; $t =~ s{/}{}; $t } 
+);

    [download]

    Then call the sub when you get a match. 

    $data = $value->( $data );

    [download]
[reply]
[d/l]
[select]
Re: Using a regex function from a hash
by friedo (Prior) on Aug 02, 2006 at 18:49 UTC
    You could wrap the substitution in a code reference: 

    my %functions_hash = ( '\.vms' => sub { $_[0] =~ s{/}{} } );
...
if ( $data =~ /$key/ ) { 
    $value->( $data );
}

    [download]
[reply]
[d/l]
      EXCELLENT. now a follow up. I am trying to get the word out of a line without much success. Here is some example lines:

      Created by GeorgeO at the parker inn
      date : 06-Aug-06:22.34.01 buncahstuffIdon'twant
      Created by 7of9 at the parker inn
      date : 06-Jan-06:22.34.01 buncahstuffIdon'twant
      Please get me:
      GeorgeO
      06-Aug-06:22.34.01
      7of9
      06-Jan-06:22.34.01

      my %functions_hash = 
( '^Created by ' => sub { $_[0] =~ /^Created by (\w+)/; $_[0] = $1; },
'^date :' => sub ( $_[0] =~ /^data :(#HELP!!)/; $_[0] = $1
 );
...
if ( $data =~ /$key/ ) { 
    $value->( $data );
}

      [download]
[reply]
[d/l]
        Messed up my question on the regex thing. Here is some example lines:

        Created by a.buncha.stuff.I.dont.want\GeorgeO at the parker inn
        date : 06-Aug-06:22.34.01 buncahstuffIdon'twant
        Created by a.buncha.stuff.I.dont.want\7of9 at the parker inn
        date : 06-Jan-06:22.34.01 buncahstuffIdon'twant

        Please get me:
        GeorgeO
        06-Aug-06:22.34.01
        7of9
        06-Jan-06:22.34.01

        2006-08-03 Moved and retitled by GrandFather, as per Monastery guidelines
        Original title: 'Regex, extracting stuff from the middle of a line'

[reply]
Re: Using a regex function from a hash
by liverpole (Monsignor) on Aug 02, 2006 at 19:25 UTC
    Hi perlNinny,

    Another thing you could do, if you only want to apply regex substitutions, is to make the values of the hash list references, where the first item in the list is the left side of the substitution, and the second item is the right side of the substitution.

    Here's an example: 

    #!/usr/bin/perl -w

use strict;
use warnings;
                                                                      
+      
my @views = (
    "ignore",
    "abbbbc",
    "mn123op",
    "ignore",
    "uvwxy",
);

my %functions_hash = (
    'ab+c$' => [ 'b+',    'x' ],
    'mn\d+' => [ '(\d+)', '<number>' ],
    'uvwxy' => [ 'uvw',   'UVW' ],
);

foreach my $data (@views)
{
   while (my ($key, $pvalue) = each %functions_hash)
   {
      if ($data =~ /$key/)
      {
          my ($from, $to) = ($pvalue->[0], $pvalue->[1]);
          $data =~ s/$from/$to/;
          print "data is now $data\n";
      }
   }
}

    [download]

    Which gives these results: 

    data is now axc
data is now mn<number>op
data is now UVWxy

    [download]
    s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
[reply]
[d/l]
[select]
      ..or put another way..? 
      my @view = ("ignore","ignore","dont\\ignore\\this.vms","ignore");
my %functions_hash = ( "\.vms" => [ qr/\\/, "" ] );

foreach my $data (@view) {
   while ((my $key, my $value) = each %functions_hash) {
      if( $data =~ /$key/ ) {
          my ( $match, $substitute ) = @{$value};
          $data =~ s/$match/$substitute/g;
          print "data is now $data\n";
      }
   }
}

      [download]
[reply]
[d/l]
Re: Using a regex function from a hash
by Moron (Curate) on Aug 03, 2006 at 09:54 UTC
    Because there is no built-in regexp-based lookup into a hash, the regexps might as well be paired with a reference to the code for each regexp, a.k.a a 'dispatch table': 
    my @dispatch = [ [ '\.vms',
                   sub { my $fnam = shift;
                         $fnam =~ s/\///g;
                         return $fnam; }
                 ]
               # ,[] ...
               ];

for ( my $v=0; $v <= $#view; $v++ ) {
    REGEXP: for ( my $d=0; $d <= $#dispatch; $d++ ) {
        if ( $view[$v] =~ /$dispatch[ $d ][0]/ ) {
            $view[$v]=&{$dispatch[$d][1]} ($view[$v]);
            last REGEXP;
        }
    } 
}

    [download]
    (updated to correct a typo - see reply below)

    -M

    Free your mind

[reply]
[d/l]
      This makes the most sense to me, but, I think this line: 
                 $view[$v]=&{$dispatch[$d][0]} ($view[$v]);

      [download]
      should probably be this 
                 $view[$v]=&{$dispatch[$d][1]} ($view[$v]);

      [download]
[reply]
[d/l]
[select]
        absolutely - well spotted!

        -M

        Free your mind

[reply]
Re: Using a regex function from a hash
by weingart (Acolyte) on Aug 03, 2006 at 20:58 UTC
    In particular, have a look at the "Execute command" part. 
    #!/usr/bin/perl
#
# $Id: whatprog,v 1.2 1994/11/20 06:19:00 weingart Exp weingart $
#
# Whatnowproc for MH-6.8

# Get the command line arguments
push(@ARGV, split(' ', `mhparam whatnow`));

# Dispatch table
%dispatch = (
        'alias',        'alias_proc',
        'echo',         'echo_proc',
        'edit',         'edit_proc',
        'encrypt',      'encrypt_proc',
        'env',          'env_proc',
        'mime',         'mime_proc',
        'quit',         'quit_proc',
        'send',         'send_proc',
        'set',          'set_proc',
        'sign',         'sign_proc',
        'unalias',      'unalias_proc',
        'unset',        'unset_proc',
);

# Alias table
%aliases = (
);

# Variables table
%var = (
        'prompt',               '"Draft($message): "',
        'alias_level',  10,
);


# Mainline
{
        # Init variables
        foreach $key (keys %ENV){
                next if($key !~ m/^mh/);

                $var{$key} = $ENV{$key};
        }
        split(/\//, $ENV{'mhdraft'});
        $var{'message'} = pop(@_);

        # Read init file
        if(open(INIT, "$ENV{HOME}/.whatnowrc")){
                while(<INIT>){
                        &do_command($_);
                }
                close(INIT);
        }

        # Command loop
        &prompt;
        while(<>){
                # Execute command
                &do_command($_);

                &prompt;
        }
        exit(0);
}


# Handle command
sub do_command {
        local($cmd) = $_[0];
        local(@cmd);

        # Massage line into list
        chop($cmd);
        @cmd = &do_token($cmd);
        return if($#cmd == -1);

        # Interpolate vars
        @cmd = &do_vars(@cmd);

        # Do aliases
        @cmd = &do_aliases(@cmd);

        # Execute cmd
        if(defined($dispatch{$cmd[0]})){
                &{ $dispatch{$cmd[0]} }(@cmd);
                print "$@\n" if($@);
        }else{
                print "Not finished yet\n";
        }
}

# Do aliases
sub do_aliases {
        local(@args) = @_;
        local($deep) = 0;

        while(defined($aliases{$args[0]}) && ($deep != $var{'alias_lev
+el'})){
                $args[0] = $aliases{$args[0]} if(defined($aliases{$arg
+s[0]}));
                $deep++;

                print "Infinite recursion...\n" if($deep == $var{'alia
+s_level'});
        }
        if($deep >= $var{'alias_level'}){
                &prompt;
                next;
        }

        return(@args);
}


# Print out prompt
sub prompt {
        local($message);
        local($prompt);

        split('/', $ENV{'mhdraft'});
        $message = pop(@_);

        if(defined($var{'prompt'})){
                $prompt = eval("$var{'prompt'}");
                print "$prompt";
        }else{
                print "Draft $message> ";
        }
        flush;
}


# Unalias an alias
sub unalias_proc {
        local(@args) = @_;
        local($cmd);

        $cmd = shift(@args);
        $cmd = shift(@args);

        if(!defined($aliases{$cmd})){
                if($cmd !~ m/^\s*$/){
                        print "Alias $cmd does not exist!\n";
                }else{
                        print "Huh, say what?\n";
                }
        }else{
                delete($aliases{$cmd});
        }
}


# Alias some command
sub alias_proc {
        local(@args) = @_;
        local($cmd, $exp, $tmp);

        $cmd = shift(args);
        $cmd = shift(args);
        $exp = join(' ', @args);

        if(defined($dispatch{$cmd})){
                print "Can not alias that!\n";
                return;
        }

        if($exp !~ m/^\s*$/){
                $aliases{$cmd} = $exp;
        }else{
                foreach $tmp (keys %aliases){
                        print "$tmp\t->\t$aliases{$tmp}\n";
                }
        }
}


# Echo arguments
sub echo_proc {
        local(@args) = @_;

        shift(@args);
        print join(' ', @args);
        print "\n";
}


# Set a variable
sub set_proc {
        local(@args) = @_;
        local($tmp);

        if($#args == 0){
                foreach $tmp (keys %var){
                        print "$tmp = $var{$tmp}\n";
                }
        }else{
                $var{$args[1]} = $args[3];
        }
}


# Unset a variable
sub unset_proc {
        local(@args) = @_;
        local($tmp);

        return if($#args != 1);

        $tmp = $args[1];
        delete $var{$tmp} if(defined($var{$tmp}));
}


# Interpolate variables
sub do_vars {
        local(@args) = @_;
        local($tmp);

        foreach $tmp (@args){
                next if($tmp !~ m/^\$([a-zA-Z]\w*)/);

                if(!defined($var{$1})){
                        print "\$$1 is not defined.\n";
                }else{
                        $tmp =~ s/\$(\w+)/$var{"$1"}/;
                }
        }

        return(@args);
}


# Encrypt a document
sub encrypt_proc {
        print "Hang on sloopy!\n";
        print @_;
}


# Sign a document
sub sign_proc {
        print "Hang on sloopy!\n";
        print @_;
}


# Mime a document
sub mime_proc {
        local($mimeproc);
        local(@mimeproc);

        chop($mimeproc = `mhparam buildmimeproc`);
        chop($mimeproc = `mhparam automhnproc`) if($mimeproc eq '');
        @mimeproc = split(/\s+/, $mimeproc);
        system(@mimeproc, "$ENV{'mhdraft'}");
}


# Send a document
sub send_proc {
        local($sendproc);
        local(@sendproc);
        local($domime);

        chop($domime = `mhparam automimeproc`);
        &mime_proc if($domime eq '1');
        chop($sendproc = `mhparam sendproc`);
        @sendproc = split(/\s+/, $sendproc);
        system(@sendproc, "$ENV{'mhdraft'}");
}


# Edit a document
sub edit_proc {
        system("$ENV{'mheditor'}", "$ENV{'mhdraft'}");
}


# Print environment
sub env_proc {
        local($i);

        foreach $i (keys %ENV){
                next if($i !~ m/^mh/i);
                print "$i => $ENV{$i}\n";
        }
}


# Quit this
sub quit_proc {
        local(@args);
        local($tmp);

        $tmp = join(' ', @_);
        @args = split(/\s+/, $tmp);

        if(!grep(/^-nodel(ete)?/, @args)){
                $tmp = $ENV{'mhdraft'};
                $tmp =~ s|/(\d+)$|/,$1|;
                rename($ENV{'mhdraft'}, $tmp);
        }

        exit(0);
}


# Tokenize line
sub do_token {
        local($line) = $_[0];
        local(@match) = ();
        local(@what) = ();
        local($i, $tmp);


        for($i = 0; $line ne ''; $i++){

                # BLANK
                if($line =~ m/^(\s+)/){
                        $line = substr($line, length($1));
                }

                # WORD
                if($line =~ m/^(\w+)/){
                        $what[$i] = 'WORD';
                        $match[$i] = $1;
                        $line = substr($line, length($1));
                        next;
                }

                # VAR
                if($line =~ m/^(\$[a-zA-Z]\w*)/){
                        $what[$i] = 'VAR';
                        $match[$i] = $1;
                        $line = substr($line, length($1));
                        next;
                }

                # STRING
                if($line =~ m/^("[^"]*")/){
                        $what[$i] = 'STRING';
                        $match[$i] = $1;
                        $line = substr($line , length($1));
                        next;
                }

                # SPECIAL
                if($line =~ m/^([=])/){
                        $what[$i] = 'SPECIAL';
                        $match[$i] = $1;
                        $line = substr($line, length($1));
                        next;
                }

                # Comment
                if($line =~ m/^(#.*)/){
                        $line = substr($line, length($1));
                        next;
                }

                # ERROR
                if($line =~ m/^(.+)$/){
                        print "Found ERROR($1).\n";
                        $line = substr($line, length($1));
                        next;
                }

        }

        return(@match);
}

    [download]

    2006-08-04 Retitled by planetscape, as per Monastery guidelines

    Read more... view votes (25 Bytes)

    Original title: 'I use something like this:'

[reply]
[d/l]

      Not to be picky, as the code is pretty clear (and complete!) but all those local() declarations on the functions shoould really be my() declarations, IMO... local() does not create a local variable... (Perl 5! check the docs)

      best regards!

      --
      our $Perl6 is Fantastic;

[reply]
[d/l]
        Much of this was written quite some time ago... :) Yes, it needs a rewrite, but other things usually take precedence.. -T.
[reply]
Re: Using a regex function from a hash
by aufflick (Deacon) on Aug 04, 2006 at 03:56 UTC
    Your approach could be fine if you wanted to restrict the allowed functions only to simple replacements. With a few minor tweaks I get this:

    use strict;

my @views = ("ignore","ignore","dont\\ignore\\this.vms","ignore");

my %regex_hash = (
    '\.vms' => [ qr/\\/ , '/' ],
   );

for my $data (@views) {
    for my $re_key ( grep { $data =~ /$_/ } keys %regex_hash ) {
        $data =~ s!$regex_hash{$re_key}[0]!$regex_hash{$re_key}[1]!g;
    }
}

print join "\n", @views;

    [download]
    and the result is: 
    ignore
ignore
dont/ignore/this.vms

    [download]
    In regex_hash the key is the regex (as a string) to match against the view data. The first entry in the value arrayref is the match portion of the substitution. The second entry in the value arrayref is the replace portion of the substitution.

    You'd have to be careful of using ! (in this implementation) in the key or the second value because I used it for the substitution delimiter.

    Becuase of this and the flexibility offered by a sub dispatch table you're probably better off going that way, but I thought I'd show you how close you were to making it work!

    Update: Just realised that liverpole already pointed this out. Using qr as in my example is a good idea however - it is more efficient and will protect you against quoting issues. See perlre if you are unfamiliar with qr

[reply]
[d/l]
[select]

Back to Seekers of Perl Wisdom

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: perlquestion [id://565288]
Approved by friedo
Front-paged by friedo
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others studying the Monastery: (5)
As of 2024-04-24 06:25 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found