File Coverage

blib/lib/Mail/Box/FastScalar.pm
Criterion Covered Total %
statement 48 115 41.7
branch 10 36 27.7
condition 2 10 20.0
subroutine 13 39 33.3
pod 0 24 0.0
total 73 224 32.5


line stmt bran cond sub pod time code
1             # Copyrights 2001-2023 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.03.
5             # This code is part of distribution Mail-Message. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Mail::Box::FastScalar;
10 34     34   1896 use vars '$VERSION';
  34         74  
  34         1875  
11             $VERSION = '3.013';
12              
13              
14 34     34   206 use strict;
  34         79  
  34         724  
15 34     34   158 use warnings;
  34         90  
  34         961  
16 34     34   18291 use integer;
  34         519  
  34         203  
17              
18              
19             sub new($) {
20 12     12 0 36 my ($class, $ref) = @_;
21 12 50       43 $$ref = '' unless defined $$ref;
22 12         68 bless { ref => $ref, pos => 0 }, $class;
23             }
24              
25       0 0   sub autoflush() {}
26              
27       12 0   sub binmode() {}
28              
29 0     0 0 0 sub clearerr { return 0; }
30              
31       0 0   sub flush() {}
32              
33 0     0 0 0 sub sync() { return 0; }
34              
35 0     0 0 0 sub opened() { return $_[0]->{ref}; }
36              
37             sub open($) {
38 0     0 0 0 my $self = $_[0];
39              
40 0 0       0 ${$_[1]} = '' unless defined(${$_[1]});
  0         0  
  0         0  
41 0         0 $self->{ref} = $_[1];
42 0         0 $self->{pos} = 0;
43             }
44              
45             sub close() {
46 12     12 0 33 undef $_[0]->{ref};
47             }
48              
49             sub eof() {
50 0     0 0 0 my $self = $_[0];
51              
52 0         0 return $self->{pos} >= length(${$self->{ref}});
  0         0  
53             }
54              
55             sub getc() {
56 0     0 0 0 my $self = $_[0];
57              
58 0         0 return substr(${$self->{ref}}, $self->{pos}++, 1);
  0         0  
59             }
60              
61             sub print {
62 0     0 0 0 my $self = shift;
63 0         0 my $pos = $self->{pos};
64 0         0 my $ref = $self->{ref};
65 0         0 my $len = length($$ref);
66            
67 0 0       0 if ($pos >= $len) {
68 0         0 $$ref .= $_ foreach @_;
69 0         0 $self->{pos} = length($$ref);
70             } else {
71 0 0       0 my $buf = $#_ ? join('', @_) : $_[0];
72            
73 0         0 $len = length($buf);
74 0         0 substr($$ref, $pos, $len) = $buf;
75 0         0 $self->{pos} = $pos + $len;
76             }
77 0         0 1;
78             }
79              
80             sub read($$;$) {
81 0     0 0 0 my $self = $_[0];
82 0         0 my $buf = substr(${$self->{ref}}, $self->{pos}, $_[2]);
  0         0  
83 0         0 $self->{pos} += $_[2];
84              
85 0 0       0 ($_[3] ? substr($_[1], $_[3]) : $_[1]) = $buf;
86 0         0 return length($buf);
87             }
88              
89             sub sysread($$;$) {
90 0     0 0 0 return shift()->read(@_);
91             }
92              
93             sub seek($$) {
94 20     20 0 46 my $self = $_[0];
95 20         30 my $whence = $_[2];
96 20         28 my $len = length(${$self->{ref}});
  20         45  
97              
98 20 50       45 if ($whence == 0) {
    0          
    0          
99 20         37 $self->{pos} = $_[1];
100             } elsif ($whence == 1) {
101 0         0 $self->{pos} += $_[1];
102             } elsif ($whence == 2) {
103 0         0 $self->{pos} = $len + $_[1];
104             } else {
105 0         0 return;
106             }
107 20 50       64 if ($self->{pos} > $len) {
    50          
108 0         0 $self->{pos} = $len;
109             } elsif ($self->{pos} < 0) {
110 0         0 $self->{pos} = 0;
111             }
112 20         41 return 1;
113             }
114              
115             sub sysseek($$) {
116 0     0 0 0 return $_[0]->seek($_[1], $_[2]);
117             }
118              
119             sub setpos($) {
120 20     20 0 56 return $_[0]->seek($_[1], 0);
121             }
122              
123             sub sref() {
124 0     0 0 0 return $_[0]->{ref};
125             }
126              
127             sub getpos() {
128 85     85 0 160 return $_[0]->{pos};
129             }
130              
131             sub tell() {
132 163     163 0 378 return $_[0]->{pos};
133             }
134              
135             sub write($$;$) {
136 0     0 0 0 my $self = $_[0];
137 0         0 my $pos = $self->{pos};
138 0         0 my $ref = $self->{ref};
139 0         0 my $len = length($$ref);
140              
141 0 0       0 if ($pos >= $len) {
142 0   0     0 $$ref .= substr($_[1], $_[3] || 0, $_[2]);
143 0         0 $self->{pos} = length($$ref);
144 0         0 $len = $self->{pos} - $len;
145             } else {
146 0   0     0 my $buf = substr($_[1], $_[3] || 0, $_[2]);
147            
148 0         0 $len = length($buf);
149 0         0 substr($$ref, $pos, $len) = $buf;
150 0         0 $self->{pos} = $pos + $len;
151             }
152 0         0 return $len;
153             }
154              
155             sub syswrite($;$$) {
156 0     0 0 0 return shift()->write(@_);
157             }
158              
159             sub getline() {
160 200     200 0 279 my $self = $_[0];
161 200         301 my $ref = $self->{ref};
162 200         267 my $pos = $self->{pos};
163              
164 200 100 66     904 if (!defined($/) || (my $idx = index($$ref, $/, $pos)) == -1) {
165 2 50       19 return if ($pos >= length($$ref));
166 2         8 $self->{pos} = length($$ref);
167 2         8 return substr($$ref, $pos);
168             } else {
169 198         868 return substr($$ref, $pos, ($self->{pos} = $idx + length($/)) - $pos);
170             }
171             }
172              
173             sub getlines() {
174 12     12 0 25 my $self = $_[0];
175 12         19 my @lines;
176 12         23 my $ref = $self->{ref};
177 12         30 my $pos = $self->{pos};
178              
179 12 50       44 if (defined($/)) {
180 12         19 my $idx;
181            
182 12         74 while (($idx = index($$ref, $/, $pos)) != -1) {
183 14         42 push(@lines, substr($$ref, $pos, ($idx + 1) - $pos));
184 14         38 $pos = $idx + 1;
185             }
186             }
187 12         45 my $r = substr($$ref, $pos);
188 12 50       50 if (length($r) > 0) {
189 0         0 push(@lines, $r);
190             }
191 12         37 $self->{pos} = length($$ref);
192 12 50       54 return wantarray() ? @lines : \@lines;
193             }
194              
195             sub TIEHANDLE {
196 0 0 0 0     ((defined($_[1]) && UNIVERSAL::isa($_[1], "Mail::Box::FastScalar"))
197             ? $_[1] : shift->new(@_));
198             }
199              
200 0     0     sub GETC { shift()->getc(@_) }
201 0     0     sub PRINT { shift()->print(@_) }
202 0     0     sub PRINTF { shift()->print(sprintf(shift, @_)) }
203 0     0     sub READ { shift()->read(@_) }
204 0 0   0     sub READLINE { wantarray ? shift()->getlines(@_) : shift()->getline(@_) }
205 0     0     sub WRITE { shift()->write(@_); }
206 0     0     sub CLOSE { shift()->close(@_); }
207 0     0     sub SEEK { shift()->seek(@_); }
208 0     0     sub TELL { shift()->tell(@_); }
209 0     0     sub EOF { shift()->eof(@_); }
210              
211             1;
212              
213             1;