]>
Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/IO.pm
0ea5d9cd665a0fc4a8c52ae08657680e921aaa0d
1 package File
::KDBX
::IO
;
2 # ABSTRACT: Base IO class for KDBX-related streams
7 use Devel
::GlobalDestruction
;
8 use File
::KDBX
::Util
qw(:empty :bool);
9 use List
::Util
qw(sum0);
10 use Ref
::Util
qw(is_blessed_ref is_ref is_scalarref);
11 use Symbol
qw(gensym);
14 use parent
'IO::Handle';
16 our $VERSION = '999.999'; # VERSION
18 sub _croak
{ require Carp
; goto &Carp
::croak
}
22 _buffer_in
=> sub { [] },
23 _buffer_out
=> sub { [] },
28 while (my ($attr, $default) = each %ATTRS) {
29 no strict
'refs'; ## no critic (ProhibitNoStrict)
32 *$self->{$attr} = shift if @_;
33 *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
38 my $class = shift || (caller)[0];
39 my $self = bless gensym
, ref($class) || $class;
40 tie
*$self, $self if 5.005 <= $];
45 return if in_global_destruction
;
52 my $fh = $self->_fh // return TRUE
;
59 return FALSE
if @{$self->_buffer_in};
60 my $fh = $self->_fh // return TRUE
;
61 local *$self->{_error
} = *$self->{_error
};
62 my $char = $self->getc || return TRUE
;
65 sub read { shift-
>sysread(@_) }
69 return FALSE
if !$self->write($buf, length($buf));
73 sub printf { shift-
>print(sprintf(@_)) }
74 sub say { shift-
>print(@_, "\n") }
75 sub getc { my $c; (shift-
>read($c, 1) // 0) == 1 ? $c : undef }
78 my ($out, $len, $offset) = @_;
79 $out = \
$_[0] if !is_scalarref
($out);
82 $self->_mode('r') if !$self->_mode;
84 my $fh = $self->_fh or return 0;
85 return 0 if defined $len && $len == 0;
87 my $append = $self->_append_output;
93 if (length($$out) < $offset) {
94 $$out .= "\0" x
($offset - length($$out));
97 substr($$out, $offset) = '';
101 elsif (!defined $$out) {
107 my $buffer = $self->_buffer_in;
108 my $buffer_len = $self->_buffer_in_length;
110 if (!$len && !$offset) {
112 my $blen = length($buffer->[0]);
114 $$out .= shift @$buffer;
117 $$out = shift @$buffer;
122 my $fill = $self->_FILL($fh) or return 0;
129 return length($fill);
133 while ($buffer_len < $len) {
134 my $fill = $self->_FILL($fh);
136 $self->_buffer_in_add($fill);
137 $buffer_len += length($fill);
141 while ($read_len < $len && @$buffer) {
142 my $wanted = $len - $read_len;
143 my $read = shift @$buffer;
144 if ($wanted < length($read)) {
145 $$out .= substr($read, 0, $wanted, '');
146 unshift @$buffer, $read;
147 $read_len += $wanted;
151 $read_len += length($read);
158 my ($self, $buf, $len, $offset) = @_;
159 $len //= length($buf);
162 $self->_mode('w') if !$self->_mode;
164 return $self->_WRITE(substr($buf, $offset, $len), $self->_fh);
169 my $fh = $self->_fh // return FALSE
;
170 return $fh->autoflush(@_);
175 my $fh = $self->_fh // return FALSE
;
181 if (!defined $/) { # SLURP
182 local *$self->{_append_output
} = 1;
184 1 while 0 < $self->read($data);
187 elsif (is_scalarref
($/) && ${$/} =~ /^\d+$/ && 0 < ${$/}) {
189 goto &_not_implemented
;
191 elsif (length $/ == 0) {
193 goto &_not_implemented
;
197 goto &_not_implemented
;
202 wantarray or _croak
'Must call getlines in list context';
204 while (defined (my $line = $self->getline)) {
210 my ($self, $ord) = @_;
211 unshift @{$self->_buffer_in}, chr($ord);
215 my ($self, $buf, $len, $offset) = @_;
216 return $self->syswrite($buf, $len, $offset) == $len;
220 return !!$self->_error;
224 my $fh = $self->_fh // return -1;
225 $self->_error(undef);
230 my $fh = $self->_fh // return undef;
235 my $fh = $self->_fh // return undef;
241 my $orig = $self->autoflush;
242 my $r = $self->print(@_);
243 $self->autoflush($orig);
248 my $fh = $self->_fh // return TRUE
;
249 return $fh->blocking(@_);
252 sub format_write
{ goto &_not_implemented
}
253 sub new_from_fd
{ goto &_not_implemented
}
254 sub fcntl { goto &_not_implemented
}
255 sub fileno { goto &_not_implemented
}
256 sub ioctl { goto &_not_implemented
}
257 sub stat { goto &_not_implemented
}
258 sub truncate { goto &_not_implemented
}
259 sub format_page_number
{ goto &_not_implemented
}
260 sub format_lines_per_page
{ goto &_not_implemented
}
261 sub format_lines_left
{ goto &_not_implemented
}
262 sub format_name
{ goto &_not_implemented
}
263 sub format_top_name
{ goto &_not_implemented
}
264 sub input_line_number
{ goto &_not_implemented
}
265 sub fdopen
{ goto &_not_implemented
}
266 sub untaint
{ goto &_not_implemented
}
268 ##############################################################################
270 sub _buffer_in_add
{ push @{shift-
>_buffer_in}, @_ }
271 sub _buffer_in_length
{ sum0
map { length($_) } @{shift-
>_buffer_in} }
273 sub _buffer_out_add
{ push @{shift-
>_buffer_out}, @_ }
274 sub _buffer_out_length
{ sum0
map { length($_) } @{shift-
>_buffer_out} }
276 sub _not_implemented
{ _croak
'Operation not supported' }
278 ##############################################################################
281 return $_[0] if is_blessed_ref
($_[0]);
290 goto &getlines
if wantarray;
300 # *READLINE = \&getline;
310 *BINMODE
= \
&binmode;
313 sub _FILL
{ die 'Not implemented' }
315 ##############################################################################
317 if ($ENV{DEBUG_IO
}) {
318 my %debug = (level
=> 0);
340 format_lines_per_page
361 no strict
'refs'; ## no critic (ProhibitNoStrict)
362 no warnings
'redefine';
363 my $orig = *$method{CODE
};
365 local $debug{level
} = $debug{level
} + 2;
366 my $indented_method = (' ' x
$debug{level
}) . $method;
368 print STDERR
sprintf('%-20s -> %s (%s)', $indented_method, $self,
369 join(', ', map { defined ? substr($_, 0, 16) : 'undef' } @_)), "\n";
370 my $r = $orig->($self, @_) // 'undef';
371 print STDERR
sprintf('%-20s <- %s [%s]', $indented_method, $self, $r), "\n";
389 format_lines_per_page
410 This is a L<IO::Handle> subclass which provides self-tying and buffering. It currently provides an interface
411 for subclasses that is similar to L<PerlIO::via>, but this is subject to change. Don't depend on this outside
412 of the L<File::KDBX> distribution. Currently-available subclasses:
415 * L<File::KDBX::IO::Crypt>
416 * L<File::KDBX::IO::HashBlock>
417 * L<File::KDBX::IO::HmacBlock>
This page took 0.0571 seconds and 4 git commands to generate.