Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
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 chanting in the Monastery: (2)
As of 2014-08-31 00:59 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (294 votes), past polls