File Coverage

web/cgi-bin/yatt.lib/YATT/Util/Finalizer.pm
Criterion Covered Total %
statement 32 33 96.9
branch 7 12 58.3
condition 1 3 33.3
subroutine 11 12 91.6
pod 0 5 0.0
total 51 65 78.4


line stmt bran cond sub pod time code
1             # -*- mode: perl; coding: utf-8 -*-
2             package YATT::Util::Finalizer;
3 12     12   503400 use strict;
  12         19  
  12         370  
4 12     12   59 use warnings qw(FATAL all NONFATAL misc);
  12         16  
  12         501  
5              
6 12     12   55 use base qw(Exporter);
  12         19  
  12         1264  
7             BEGIN {
8 12     12   42 our @EXPORT = qw(with_select capture finally);
9 12         4783 our @EXPORT_OK = @EXPORT;
10             }
11              
12             sub new {
13 162     162 0 490 my ($pack, $code) = splice @_, 0, 2;
14 162         735 bless [$code, @_], $pack;
15             }
16              
17             sub finally (&@) {
18 162     162 0 1271 __PACKAGE__->new(@_);
19             }
20              
21             sub DESTROY {
22 162     162   342 my $self = shift;
23 162 100       557 if ($@) {
24             # XXX: This can be hard to catch.
25 32 50       139 syswrite STDOUT, "\n\n[$@]" if $ENV{DEBUG_ERROR};
26             }
27 162 50       518 my $code = $self->[0] or return;
28 162         599 $code->(@$self[1 .. $#$self]);
29             }
30              
31             sub cancel {
32 0     0 0 0 undef shift->[0];
33             }
34              
35             sub with_select {
36             # newfh, body, [strref]
37 162     162 0 278 my $strref;
38 162 50       532 unless (defined $_[0]) {
39 162   33     519 $strref = $_[2] || do {my $str = ""; \$str};
40 162 50   3   3471 open $_[0], '>', $strref or die "Can't open strref: $!";
  3         23  
  3         6  
  3         24  
41             }
42             my $finalizer = finally {
43 162     162   1886 select($_[0]);
44 162         5124 } select;
45 162         588 select($_[0]);
46 162         602 $_[1]->($finalizer);
47 130 50       939 defined $strref && $$strref;
48             }
49              
50             sub capture (&@) {
51 162     162 0 602 with_select my ($fh), $_[0];
52             }
53              
54             1;