]>
Dogcows Code - chaz/p5-File-KDBX/blob - IO.pm
4d6009ddf84e84734fecb931523dd531d4758fae
1 package File
::KDBX
::IO
;
2 # ABSTRACT: Base IO class for KDBX-related streams
7 use Devel
::GlobalDestruction
;
8 use File
::KDBX
::Constants
qw(:bool);
9 use File
::KDBX
::Util
qw(:class :empty);
10 use List
::Util
qw(sum0);
11 use Ref
::Util
qw(is_blessed_ref is_ref is_scalarref);
12 use Symbol
qw(gensym);
17 our $VERSION = '999.999'; # VERSION
19 sub _croak
{ require Carp
; goto &Carp
::croak
}
23 _buffer_in
=> sub { [] },
24 _buffer_out
=> sub { [] },
29 while (my ($attr, $default) = each %ATTRS) {
30 no strict
'refs'; ## no critic (ProhibitNoStrict)
33 *$self->{$attr} = shift if @_;
34 *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
39 my $class = shift || (caller)[0];
40 my $self = bless gensym
, ref($class) || $class;
41 tie
*$self, $self if 5.005 <= $];
46 return if in_global_destruction
;
47 local ($., $@, $!, $^E, $?);
54 my $fh = $self->_fh // return TRUE
;
61 return FALSE
if @{$self->_buffer_in};
62 my $fh = $self->_fh // return TRUE
;
63 local *$self->{_error
} = *$self->{_error
};
64 my $char = $self->getc || return TRUE
;
67 sub read { shift-
>sysread(@_) }
71 return FALSE
if !$self->write($buf, length($buf));
75 sub printf { shift-
>print(sprintf(@_)) }
76 sub say { shift-
>print(@_, "\n") }
77 sub getc { my $c; (shift-
>read($c, 1) // 0) == 1 ? $c : undef }
80 my ($out, $len, $offset) = @_;
81 $out = \
$_[0] if !is_scalarref
($out);
84 $self->_mode('r') if !$self->_mode;
86 my $fh = $self->_fh or return 0;
87 return 0 if defined $len && $len == 0;
89 my $append = $self->_append_output;
95 if (length($$out) < $offset) {
96 $$out .= "\0" x
($offset - length($$out));
99 substr($$out, $offset) = '';
103 elsif (!defined $$out) {
109 my $buffer = $self->_buffer_in;
110 my $buffer_len = $self->_buffer_in_length;
112 if (!$len && !$offset) {
114 my $blen = length($buffer->[0]);
116 $$out .= shift @$buffer;
119 $$out = shift @$buffer;
124 my $fill = $self->_FILL($fh) or return 0;
131 return length($fill);
135 while ($buffer_len < $len) {
136 my $fill = $self->_FILL($fh);
138 $self->_buffer_in_add($fill);
139 $buffer_len += length($fill);
143 while ($read_len < $len && @$buffer) {
144 my $wanted = $len - $read_len;
145 my $read = shift @$buffer;
146 if ($wanted < length($read)) {
147 $$out .= substr($read, 0, $wanted, '');
148 unshift @$buffer, $read;
149 $read_len += $wanted;
153 $read_len += length($read);
160 my ($self, $buf, $len, $offset) = @_;
161 $len //= length($buf);
164 $self->_mode('w') if !$self->_mode;
166 return $self->_WRITE(substr($buf, $offset, $len), $self->_fh);
171 my $fh = $self->_fh // return FALSE
;
172 return $fh->autoflush(@_);
177 my $fh = $self->_fh // return FALSE
;
183 if (!defined $/) { # SLURP
184 local *$self->{_append_output
} = 1;
186 1 while 0 < $self->read($data);
189 elsif (is_scalarref
($/) && ${$/} =~ /^\d+$/ && 0 < ${$/}) {
191 goto &_not_implemented
;
193 elsif (length $/ == 0) {
195 goto &_not_implemented
;
199 goto &_not_implemented
;
204 wantarray or _croak
'Must call getlines in list context';
206 while (defined (my $line = $self->getline)) {
212 my ($self, $ord) = @_;
213 unshift @{$self->_buffer_in}, chr($ord);
217 my ($self, $buf, $len, $offset) = @_;
218 return $self->syswrite($buf, $len, $offset) == $len;
222 return !!$self->_error;
226 my $fh = $self->_fh // return -1;
227 $self->_error(undef);
232 my $fh = $self->_fh // return undef;
237 my $fh = $self->_fh // return undef;
243 my $orig = $self->autoflush;
244 my $r = $self->print(@_);
245 $self->autoflush($orig);
250 my $fh = $self->_fh // return TRUE
;
251 return $fh->blocking(@_);
254 sub format_write
{ goto &_not_implemented
}
255 sub new_from_fd
{ goto &_not_implemented
}
256 sub fcntl { goto &_not_implemented
}
257 sub fileno { goto &_not_implemented
}
258 sub ioctl { goto &_not_implemented
}
259 sub stat { goto &_not_implemented
}
260 sub truncate { goto &_not_implemented
}
261 sub format_page_number
{ goto &_not_implemented
}
262 sub format_lines_per_page
{ goto &_not_implemented
}
263 sub format_lines_left
{ goto &_not_implemented
}
264 sub format_name
{ goto &_not_implemented
}
265 sub format_top_name
{ goto &_not_implemented
}
266 sub input_line_number
{ goto &_not_implemented
}
267 sub fdopen
{ goto &_not_implemented
}
268 sub untaint
{ goto &_not_implemented
}
270 ##############################################################################
272 sub _buffer_in_add
{ push @{shift-
>_buffer_in}, @_ }
273 sub _buffer_in_length
{ sum0
map { length($_) } @{shift-
>_buffer_in} }
275 sub _buffer_out_add
{ push @{shift-
>_buffer_out}, @_ }
276 sub _buffer_out_length
{ sum0
map { length($_) } @{shift-
>_buffer_out} }
278 sub _not_implemented
{ _croak
'Operation not supported' }
280 ##############################################################################
283 return $_[0] if is_blessed_ref
($_[0]);
292 goto &getlines
if wantarray;
302 # *READLINE = \&getline;
312 *BINMODE
= \
&binmode;
315 sub _FILL
{ die 'Not implemented' }
317 ##############################################################################
319 if ($ENV{DEBUG_IO
}) {
320 my %debug = (level
=> 0);
342 format_lines_per_page
363 no strict
'refs'; ## no critic (ProhibitNoStrict)
364 no warnings
'redefine';
365 my $orig = *$method{CODE
};
367 local $debug{level
} = $debug{level
} + 2;
368 my $indented_method = (' ' x
$debug{level
}) . $method;
370 print STDERR
sprintf('%-20s -> %s (%s)', $indented_method, $self,
371 join(', ', map { defined $_ ? substr($_, 0, 16) : 'undef' } @_)), "\n";
372 my $r = $orig->($self, @_) // 'undef';
373 print STDERR
sprintf('%-20s <- %s [%s]', $indented_method, $self, $r), "\n";
391 format_lines_per_page
412 This is a L<IO::Handle> subclass which provides self-tying and buffering. It currently provides an interface
413 for subclasses that is similar to L<PerlIO::via>, but this is subject to change. Don't depend on this outside
414 of the L<File::KDBX> distribution. Currently-available subclasses:
417 * L<File::KDBX::IO::Crypt>
418 * L<File::KDBX::IO::HashBlock>
419 * L<File::KDBX::IO::HmacBlock>
This page took 0.06178 seconds and 3 git commands to generate.