my $iter = TQDM::tqdm(1..10);

while (<$iter>) {
    print "got [$_]\n";
}
[download]

Otherwise, I think you need a custom iterator function, e.g.

sub iterate ($&) {
    my ($ary, $code) = @_;
    for (@$ary) {
        print "progress bar: $_\n";
        $code->();
    }
}

sub tqdm { bless [ @_ ] }

iterate tqdm(1..10), sub {
    print "got [$_]\n";
};
[download]

Dave.

Yes, in this case the goal is on how easy it is to add a progress indicator to an existing code that uses for(). If a user has to change her for() to while(), that would count as less easy. It's akin in spirit to data dumping modules like XXX or Data::Dmp that returns its original argument so you can insert XXX or dmp just about anywhere in an existing Perl code.

Next step after I conquer for(), will probably move on to while(). :-) Yes, I'll be looking into overloading the diamond operator or tying filehandle.

I don't think its possible in perl to write a function foo() that will allow any of the following in the way you want:

for (foo(list)) { ... }
while (foo(list)) { .... }
while (<foo(list)>) { .... }
[download]

assuming that for and while are the perl built-ins, and that you're not using source filtering or keyword plugins etc.

Dave.

Never used tie before, so this is a good learning experience, even though like LanX I do not know either what this is good for. In any case, I think, this works as required:

for( @{ tie my @x, "My::Class", "first", "second"; \@x } ) {
    print "$_\n";
}
[download]

Your code which wraps tie in @{ ... } does not work because all elements are FETCH-ed first before the loop block code is executed. I.e. in the above case, FETCH(0) and FETCH(1) are called before "first" and "second" are print-ed by print(). The @{ ... } basically turns the tied array into list of values. I need to iterate over the tied array so the code in the loop block (in this case, print()) is executed along with FETCH/FETCHSIZE.

I disagree. Here is the full code and FETCH is only called once for each element within the body of the loop:

use strict;
use warnings;

package MyClass;
    use Tie::Array;
    our @ISA = ('Tie::Array');
    our @data;
    # mandatory methods
    sub TIEARRAY { my $class = shift; bless \@data, $class; @data = @_
+; return \@data }
    sub FETCH { print "FETCH: "; my ($self, $index ) = @_; return $dat
+a[$index] }
    sub FETCHSIZE { print "<FETCHSIZE> "; return scalar @data }

package main;    
    
for( @{ tie my @x, "MyClass", "first", "second"; \@x } ) {
    print "In loop = ";
    print "$_\n";
}
[download]

Output:

In loop = FETCH: first
In loop = FETCH: second
[download]

waht?

please provide a test case clearly demonstrating what you want and what not.

for (tie @ary, "My::Class", "some", "contents") { ... } # NOPE

does not work because for() gets a single-element list which is the tied object, not the tied array itself.

for (do { tie @ary, "My::Class", "some", "contents"; @ary }) { ... } #NOPE

does not work because for() gets an ordinary (non-magical) list of values. All the values from the tied array have been FETCH-ed. I need to iterate over the tied array so code inside the loop block and FETCH are executed once for each element, together.

tie @ary, "My::Class", "some", "contents";
for (@ary) {
   ...
}
[download]

works, but I want something more similar to:

for (wrapper(@ary)) {
   ...
}
[download]

where @ary is an ordinary array or a list of values.

> because for() gets an ordinary (non-magical) list of values.

That's not how I understand the output. It seems FETCHSIZE is only called once, but each element is fetched right before the iteration:

#! /usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

{   package My;
    use Tie::Array;
    use parent -norequire => 'Tie::StdArray';
    sub TIEARRAY {
        warn "TIE: @_\n";
        my $class = shift;
        bless [@_], $class
    }
    sub FETCHSIZE {
        warn "SIZE: @_\n";
        return scalar @{ $_[0] }
    }
    sub FETCH {
        warn "FETCH: @_\n";
        my ($ar, $idx) = @_;
        my $e = $ar->[$idx];
        return ++$e
    }
}

for my $e (do { tie my @ar, 'My', qw( a b c ); @ar } ) {
    say "MAIN: $e";
}
[download]

Output:

TIE: My a b c
SIZE: My=ARRAY(0x21eff40)
FETCH: My=ARRAY(0x21eff40) 0
MAIN: b
FETCH: My=ARRAY(0x21eff40) 1
MAIN: c
FETCH: My=ARRAY(0x21eff40) 2
MAIN: d
[download]

for my $e (@ar), on the other hand, calls FETCHSIZE before each FETCH.

map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]

This:

for (tie @ary, "My::Class", "some", "contents";) {
   ...
}
[download]

is exactly what you should NOT be doing

Read: Tying-Arrays: If someone outside the class tries to dereference the object returned (doubtless thinking it an ARRAY ref), they'll blow up. This just goes to show you that you should respect an object's privacy.

FETCH and FETCHSIZE are exactly for that you can: 'respect an object's privacy':

Something like this:

my $aryt = tie @ary, "My::Class", "some", "contents";
@ary = ... ;
for (0..($aryt->FETCHSIZE-1)) {
    do-something($aryt->FETCH($_));
}
[download]

you can't bend for into an object's method.

Perl != Python

the closest to a drop in replacement is maybe a customfunction sub xfor (&&) :

xfor {@arr} sub { ...};
[download]

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery FootballPerl is like chess, only without the dice}

There is also the 3-part for:

#!/usr/bin/env perl

# author: bliako
# for: https://perlmonks.org/?node_id=1232642
# 17/04/2019

use strict;
use warnings;

package Wrapper;
# use: new(code, array)
sub new { return bless {s=>$_[1],a=>[@_[2..$#_]],c=>0}, $_[0] }
sub next {
        $_[0]->{s}->();
        scalar(@{$_[0]->{a}}) > $_[0]->{c} ? $_[0]->{a}->[$_[0]->{c}++
+] : undef
}
sub reset { $_[0]->{c} = 0 }

package main;

for($_=Wrapper->new(sub{print "hello\n"}, 1..10);my $_2=$_->next;){
        print "got=$_2\n";
}
[download]

bw, bliako

 
tie @ary, "My::Class", "some", "el", "ems";
for (@ary) {
   some_code($_);
}
[download]

What if the loop is left by last , next , redo , return or goto ?

Does the code hooked into the tied array really catch all edge cases sufficiently for your progress-bar?

edit

Is there any ->DESTROY of the tied class being called?

NB: As already told, be aware about restrictions on Perl versions.

Is there any ->DESTROY of the tied class being called?

It depends where the @ary is defined. In the solution suggested by hdb, there is a DESTROY:

use warnings;
use strict;

print "--- Begin loop ---\n";
for ( @{ tie my @ary, 'MyArray', qw/ x y z /; \@ary } ) {
    print "<$_>\n";
    last if /y/;
}
print "--- End loop ---\n";

BEGIN {
    package MyArray;
    sub TIEARRAY  { my $c = shift; bless { arr=>[@_] }, $c }
    # largely borrowed from Tie::StdArray
    sub FETCH     { $_[0]{arr}[$_[1]] }
    sub STORE     { $_[0]{arr}[$_[1]] = $_[2] }
    sub FETCHSIZE { scalar @{$_[0]{arr}} }
    sub STORESIZE { $#{$_[0]{arr}} = $_[1]-1 }
    sub EXTEND    { $#{$_[0]{arr}} = $_[1]-1 }
    sub CLEAR     { @{$_[0]{arr}} = () }
    sub POP       { pop @{$_[0]{arr}} }
    sub SHIFT     { shift @{$_[0]{arr}} }
    sub PUSH      { my $o=shift; push @{$$o{arr}}, @_ }
    sub UNSHIFT   { my $o=shift; unshift @{$$o{arr}}, @_ }
    sub EXISTS    { exists $_[0]{arr}[$_[1]] }
    sub DELETE    { delete $_[0]{arr}[$_[1]] }
    sub UNTIE     { %{$_[0]}=(); return }
    sub DESTROY   { %{$_[0]}=(); return }
    sub SPLICE {
        my $ob  = shift;
        my $sz  = $ob->FETCHSIZE;
        my $off = @_ ? shift : 0;
        $off   += $sz if $off < 0;
        my $len = @_ ? shift : $sz-$off;
        return splice(@{$$ob{arr}}, $off, $len, @_);
    }
    # debug stuff:
    use Class::Method::Modifiers qw/around/;
    use Data::Dump qw/pp/;
    my @m = qw/ CLEAR DELETE DESTROY EXISTS EXTEND FETCH FETCHSIZE POP
        PUSH SHIFT SPLICE STORE STORESIZE TIEARRAY UNSHIFT UNTIE /;
    for my $m (@m) {
        around $m => sub {
            my $orig = shift;
            my $self = shift;
            my @args = @_;
            if (wantarray) {
                my @rv = $orig->($self, @_);
                print STDERR $m," ",pp(@args)," => ",pp(@rv),"\n";
                return @rv;
            } # else
            my $rv = $orig->($self, @_);
            print STDERR $m," ",pp(@args)," => ",pp($rv),"\n";
            return $rv;
        };
    }
}

__END__

--- Begin loop ---
TIEARRAY ("x", "y", "z") => bless({ arr => ["x", "y", "z"] }, "MyArray
+")
FETCHSIZE () => 3
FETCH 0 => "x"
<x>
FETCHSIZE () => 3
FETCH 1 => "y"
<y>
DESTROY () => undef
--- End loop ---
[download]

Haven't tested it yet but your results look convincing. :)

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery FootballPerl is like chess, only without the dice}

What if the loop is left by last , next , redo , return or goto ?

Nice catch. In the Python library, this must be handled explicitly by "closing" the iterator.

> In the Python library, this must be handled explicitly

LOL...

well hooking into DESTROY should handle this implicitly.

BTW: I forgot to list die and exception handling.

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery FootballPerl is like chess, only without the dice}