Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

Loop::Watch

by japhy (Canon)
on Apr 17, 2001 at 06:51 UTC ( #73036=sourcecode: print w/ replies, xml ) Need Help??

Category: Miscellaneous
Author/Contact Info Jeff japhy Pinyan
Description: Thanks to some helpful feedback from my fellow monks, I offer Loop-Watch-0.01b. I'm not releasing it to CPAN until I have some testing results.
Here is the new code. I've tested it a bit more this time. Got rid of that deep recursion (curses, Abigail, fie on you!).

It now supports looping { ... } and doing { ... } (the latter only executes once); the function using has been replaced by the more aptly named watching.
package Loop::Watch;

use strict;
require Exporter;

@Loop::Watch::ISA = qw( Exporter );
@Loop::Watch::EXPORT = qw( ensure watching looping doing );

my %seen;


sub ensure (&@) {
  my ($cref, $obj, $loop) = @_;
  for (@$obj) {
    if (ref eq 'SCALAR') { tie $$_, 'Loop::Watch::Scalar', $$_, $cref 
+}
    elsif (ref eq 'ARRAY') { tie @$_, 'Loop::Watch::Array', [ @$_ ], $
+cref }
    elsif (ref eq 'HASH') { tie %$_, 'Loop::Watch::Hash', { %$_ }, $cr
+ef }
  }

  eval { { $loop->[1]->(); redo if $loop->[0] } };

  die $@ if $@ and $@ ne "[Loop::Watch]\n";

  for (@$obj) {
    if (ref eq 'SCALAR') {
      my $v = (tied $$_)->[0];
      untie $$_;
      $$_ = $v;
    }
    elsif (ref eq 'ARRAY') {
      my $v = (tied @$_)->[0];
      untie @$_;
      @$_ = @$v;
    }
    else {
      my $v = (tied %$_)->[0];
      untie %$_;
      %$_ = %$v;
    }
  }
}


sub watching (@) { [ map ref($_) ? $_ : \$_, @_ ] }


sub looping (&) { [ 1, $_[0] ] }


sub doing (&) { [ 0, $_[0] ] }



package Loop::Watch::Scalar;

sub TIESCALAR {
  my $class = shift;
  bless [ @_ ], $class;
}

sub FETCH {
  my $self = shift;
  my $val = $self->[0];
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}

sub STORE {
  my ($self, $val) = @_;
  $self->[0] = $val;
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}


package Loop::Watch::Array;

sub TIEARRAY {
  my $class = shift;
  bless [ @_ ], $class;
}

sub FETCH {
  my ($self, $i) = @_;
  my $val = $self->[0][$i];
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}

sub FETCHSIZE {
  my $self = shift;
  my $size = @{ $self->[0] };
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $size;
}

sub STORE {
  my ($self, $i, $val) = @_;
  $self->[0][$i] = $val;
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}

sub STORESIZE {
  my ($self, $size) = @_;
  $#{ $self->[0] } = $size;
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $size;
}

eval << 'END 5.6.0 CODE' if $^V;
sub EXISTS {
  my ($self, $i) = @_;
  my $val = exists $self->[0][$i];
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}

sub DELETE {
  my ($self, $i) = @_;
  my $val = delete $self->[0][$i];
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}
END 5.6.0 CODE

sub PUSH {
  my $self = shift;
  for (@_) {
    push @{ $self->[0] }, $_;
    $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loo
+p::Watch]\n");
  }
  return scalar @{ $self->[0] };
}

sub POP {
  my $self = shift;
  my $val = pop @{ $self->[0] };
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}

sub UNSHIFT {
  my $self = shift;
  for (reverse @_) {
    unshift @{ $self->[0] }, $_;
    $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loo
+p::Watch]\n");
  }
  return scalar @{ $self->[0] };
}

sub SHIFT {
  my $self = shift;
  my $val = shift @{ $self->[0] };
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}

sub CLEAR {
  my $self = shift;  
  $self->[0] = [];
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return;
}


package Loop::Watch::Hash;

sub TIEHASH {
  my $class = shift;
  bless [ @_ ], $class;
}

sub FETCH {
  my ($self, $key) = @_;
  my $val = $self->[0]{$key};
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}

sub STORE {
  my ($self, $key, $val) = @_;
  $self->[0]{$key} = $val;
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}

sub FIRSTKEY {
  my $self = shift;
  my ($k,$v) = each %{ $_[0][0] };
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return wantarray ? ($k,$v) : $k;
}

sub NEXTKEY {
  my $self = shift;
  my ($k,$v) = each %{ $_[0][0] };
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return wantarray ? ($k,$v) : $k;
}

sub EXISTS {
  my ($self,$key) = @_;
  my $val = exists $self->[0]{$key};
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}

sub DELETE {
  my ($self, $key) = @_;
  my $val = delete $self->[0]{$key};
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return $val;
}

sub CLEAR {
  my $self = shift;  
  $self->[0] = {};
  $seen{$self}++ ? ($seen{$self} = 0) : ($self->[1]->() or die "[Loop:
+:Watch]\n");
  return;
}


1;

Comment on Loop::Watch
Download Code
Docs and Examples for Loop::Watch
by japhy (Canon) on Apr 17, 2001 at 19:26 UTC
    Since I left these out of the code I posted, and since some people did not follow the Help Name This Module thread, here is some documentation for the Loop::Watch module.

    Abstract

    Loop::Watch is like alarm() for variables -- it watches a given set of variables (scalars, arrays, and hashes are the only ones currently supported), and exits a block of code (which may or may not be a loop) as soon as the condition it is given becomes false. It's like a while-loop that keeps tabs on the condition constantly.

    Usage

    Let's say you wanted to do a series of statements, but stop as soon as one of them caused $temperature to go below 0, and if none caused that, to continue normally with the rest of the program.
    use Loop::Watch; my $temp = 20; # celsius, that is # doing { ... } does *not* loop ensure { $temp >= 0 } watching($temp), doing { move_to_florida(); wait_until_winter(); move_to_new_jersey(); wait_until_spring(); move_to_montana(); wait_until_fall(); move_to_alaska(); wait_until_winter(); };
    That code would probably stop somewhere around the move to New Jersey. That function could do any number of things to $temperature, and this module keeps an eye on things.

    Let's say, though, you wanted to circle the globe until your money ran out:
    use Loop::Watch; my $money = 1_000_000; # in USD # looping { ... } *does* loop ensure { $money > 0 } watching($money), looping { circle_globe(); }; sub circle_globe { move_to_next_location(); purchase_lodging(); eat(); # ... }
    This allows the functions called by circle_globe() to assume you have money left -- and as soon as you don't have any money left, you stop your trip.

    You can watch multiple variables in the same block:
    use Loop::Watch; my ($age, @companies); $age = 20; ensure { $age < 35 and @companies < 10 } watching($age, \@companies), looping { $age++ if new_year(); if (my $c = acquisition_available()) { if (try_to_purchase($c)) { push @companies, $c; check_related($c); } } };
    That code will stop once you've reached 35 (good age to retire at) or you've acquired 10 companies. Maybe during the course of the new_year(), you lose a company or something -- that's ok. You needn't do any checking there, all the checking of the age and company count is done by the module.

    japhy -- Perl and Regex Hacker

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://73036]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (18)
As of 2015-07-02 10:19 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (33 votes), past polls