File Coverage

blib/lib/String/TieStack.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             # Copyright (c) 2003 Ioannis Tambouras .
2             # All rights reserved.
3              
4              
5             package String::TieStack ;
6 22     22   355637 use 5.006;
  22         85  
  22         1174  
7 22     22   307 use Carp;
  22         45  
  22         2622  
8 22     22   134 use strict;
  22         54  
  22         941  
9 22     22   113 use base 'Tie::Array';
  22         36  
  22         26924  
10 22     22   73186 use Data::Dumper;
  22         341841  
  22         2873  
11             use Class::MethodMaker
12 0           new_with_init => [qw( new TIEARRAY )],
13             new_hash_init => 'ihash',
14             list => [qw( DATA buffers )],
15             grouped_fields => [ tlimits=>[qw( max_entries max_KBytes)],
16             info =>[qw( total_bytes )], ],
17 22     22   52606 ;
  0            
18              
19             sub STORE { croak 'ERROR: operation prohibited.' }
20             *FETCH = \& STORE ;
21             *FETCHSIZE = \& DATA_count ;
22             *SPLICE = \& STORE ;
23              
24             sub import {
25             my ($self, %param) = @_ ;;
26             $__PACKAGE__::DEFAULTS{max_entries} = $param{max_entries} || 0 ;
27             $__PACKAGE__::DEFAULTS{max_KBytes} = $param{max_KBytes} || 0 ;
28             };
29              
30             sub init {
31             my $self = shift;
32             $self->buffers_clear;
33             $self->DATA_clear;
34             $self->ihash( %__PACKAGE__::DEFAULTS, @_ ) ;
35             $self->{top} = $self->{total_bytes} = 0 ;
36             }
37              
38              
39             sub limits {
40             my $self = shift;
41             ( @_ == 2 ) ? ( $self->max_entries( $_[0] ) ,
42             $self->max_KBytes( $_[1] ) , return @_[0,1] )
43             : ( return ($self->max_entries()||0, $self->max_KBytes|| 0 )) ;
44             }
45              
46             sub _bytes {
47             my $sum;
48             $sum += length($_||'') for @_ ;
49             $sum;
50             }
51              
52              
53             sub _allowed_p {
54             my $self = shift;
55             my ($etarget, $new_bytes) = ( $self->FETCHSIZE() + scalar @_ , _bytes(@_) );
56             return 0 if ($self->max_entries) && ($etarget > $self->max_entries );
57              
58             my $btarget = ($self->{total_bytes} || 0) + $new_bytes ;
59             my $blimit = ($self->max_KBytes || 0) * 1024 ;
60             return 0 if ($self->max_KBytes) && ($btarget > $blimit);
61             $new_bytes;
62             };
63              
64              
65             sub UNSHIFT {
66             my ($self, @val) = @_ ;
67             return undef unless my $bytes = &_allowed_p ;
68             $self->DATA_splice( $self->{top} , 0, @val );
69             $self->{total_bytes} = $self->{total_bytes} + $bytes ;
70             }
71              
72              
73             sub PUSH {
74             my ($self, @val) = @_ ;
75             return undef unless my $bytes = &_allowed_p ;
76             $self->{total_bytes} = $self->{total_bytes} + $bytes ;
77             $self->DATA_push( @val ) ;
78             }
79              
80             sub POP {
81             my $self = shift;
82             $self->dropbuf if $self->FETCHSIZE <= $self->{top} ;
83             my $ret = $self->DATA_pop ;
84             $self->total_bytes( $self->total_bytes - _bytes($ret));
85             $ret;
86             }
87              
88             sub CLEAR {
89             my $self = shift;
90             my ($entries , $bytes) = ($self->max_entries(), $self->max_KBytes() ) ;
91             $self->init(@_);
92             $self->max_entries( $entries ) ;
93             $self->max_KBytes( $bytes ) ;
94             }
95              
96             sub makebuf {
97             my $self = shift;
98             return undef if $self->{top} == $self->FETCHSIZE;
99             $self->{top} = $self->FETCHSIZE ;
100             $self->buffers_push ( $self->{top} );
101             }
102              
103             sub dropbuf {
104             my $self = shift;
105             return unless $self->buffers_count;
106             my $start = $self->buffers_pop();
107             my $end = $self->DATA_count;
108             $self->DATA_splice( $start, $end );
109             $self->{top} = $self->buffers_index( $self->buffers_count - 1 ) || 0;
110             }
111              
112             sub desbuf {
113             my $self = shift;
114             return unless $self->buffers_count;
115             $self->dropbuf for $self->buffers;
116             }
117              
118             sub queue { shift->UNSHIFT( reverse @_ ) }
119             sub pdumpq { print &dumpq }
120             *qelem = \& DATA_count ;
121             *queued = \& qelem ;
122             *qbuf = \& buffers_count ;
123             *printq = \& DATA ;
124             sub dumpq { Data::Dumper->Dump( [shift], ['tieStack'] ) }
125              
126             sub pullbuf {
127             my ($self, $num) = shift;
128             return undef unless $self->buffers_count ;
129             $num = $self->DATA_count - $self->{top};
130             $self->pull( $num );
131             }
132              
133             sub pull {
134             my ($self, $num) = @_;
135             $num = (defined $num) ? $num : 1;
136             return undef unless ($self->qelem() - $num) > -1 ;
137             my @ret;
138             push @ret, $self->POP for (1..$num);
139             @ret;
140             }
141              
142             sub pullall {
143             my $self = shift;
144             my @ret = $self->DATA;
145             $self->CLEAR;
146             @ret;
147             };
148              
149             1;
150             __END__