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__ |