Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/IO.pm

   1 package File::KDBX::IO;
   2 # ABSTRACT: Base IO class for KDBX-related streams
   3
   4 use warnings;
   5 use strict;
   6
   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);
  12 use namespace::clean;
  13
  14 use parent 'IO::Handle';
  15
  16 our $VERSION = '999.999'; # VERSION
  17
  18 sub _croak { require Carp; goto &Carp::croak }
  19
  20 my %ATTRS = (
  21     _append_output  => 0,
  22     _buffer_in      => sub { [] },
  23     _buffer_out     => sub { [] },
  24     _error          => undef,
  25     _fh             => undef,
  26     _mode           => '',
  27 );
  28 while (my ($attr, $default) = each %ATTRS) {
  29     no strict 'refs'; ## no critic (ProhibitNoStrict)
  30     *$attr = sub {
  31         my $self = shift;
  32         *$self->{$attr} = shift if @_;
  33         *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
  34     };
  35 }
  36
  37 sub new {
  38     my $class = shift || (caller)[0];
  39     my $self = bless gensym, ref($class) || $class;
  40     tie *$self, $self if 5.005 <= $];
  41     return $self;
  42 }
  43
  44 sub DESTROY {
  45     return if in_global_destruction;
  46     my $self = shift;
  47     $self->close;
  48 }
  49
  50 sub close {
  51     my $self = shift;
  52     my $fh = $self->_fh // return TRUE;
  53     $self->_POPPED($fh);
  54     $self->_fh(undef);
  55     return $fh->close;
  56 }
  57 sub eof {
  58     my $self = shift;
  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;
  63     $self->ungetc($char);
  64 }
  65 sub read { shift->sysread(@_) }
  66 sub print {
  67     my $self = shift;
  68     for my $buf (@_) {
  69         return FALSE if !$self->write($buf, length($buf));
  70     }
  71     return TRUE;
  72 }
  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 }
  76 sub sysread {
  77     my $self = shift;
  78     my ($out, $len, $offset) = @_;
  79     $out = \$_[0] if !is_scalarref($out);
  80     $offset //= 0;
  81
  82     $self->_mode('r') if !$self->_mode;
  83
  84     my $fh = $self->_fh or return 0;
  85     return 0 if defined $len && $len == 0;
  86
  87     my $append = $self->_append_output;
  88     if (!$append) {
  89         if (!$offset) {
  90             $$out = '';
  91         }
  92         else {
  93             if (length($$out) < $offset) {
  94                 $$out .= "\0" x ($offset - length($$out));
  95             }
  96             else {
  97                 substr($$out, $offset) = '';
  98             }
  99         }
 100     }
 101     elsif (!defined $$out) {
 102         $$out = '';
 103     }
 104
 105     $len ||= 0;
 106
 107     my $buffer = $self->_buffer_in;
 108     my $buffer_len = $self->_buffer_in_length;
 109
 110     if (!$len && !$offset) {
 111         if (@$buffer) {
 112             my $blen = length($buffer->[0]);
 113             if ($append) {
 114                 $$out .= shift @$buffer;
 115             }
 116             else {
 117                 $$out = shift @$buffer;
 118             }
 119             return $blen;
 120         }
 121         else {
 122             my $fill = $self->_FILL($fh) or return 0;
 123             if ($append) {
 124                 $$out .= $fill;
 125             }
 126             else {
 127                 $$out = $fill;
 128             }
 129             return length($fill);
 130         }
 131     }
 132
 133     while ($buffer_len < $len) {
 134         my $fill = $self->_FILL($fh);
 135         last if empty $fill;
 136         $self->_buffer_in_add($fill);
 137         $buffer_len += length($fill);
 138     }
 139
 140     my $read_len = 0;
 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;
 148         }
 149         else {
 150             $$out .= $read;
 151             $read_len += length($read);
 152         }
 153     }
 154
 155     return $read_len;
 156 }
 157 sub syswrite {
 158     my ($self, $buf, $len, $offset) = @_;
 159     $len    //= length($buf);
 160     $offset //= 0;
 161
 162     $self->_mode('w') if !$self->_mode;
 163
 164     return $self->_WRITE(substr($buf, $offset, $len), $self->_fh);
 165 }
 166
 167 sub autoflush {
 168     my $self = shift;
 169     my $fh = $self->_fh // return FALSE;
 170     return $fh->autoflush(@_);
 171 }
 172
 173 sub opened {
 174     my $self = shift;
 175     my $fh = $self->_fh // return FALSE;
 176     return TRUE;
 177 }
 178 sub getline {
 179     my $self = shift;
 180
 181     if (!defined $/) {  # SLURP
 182         local *$self->{_append_output} = 1;
 183         my $data;
 184         1 while 0 < $self->read($data);
 185         return $data;
 186     }
 187     elsif (is_scalarref($/) && ${$/} =~ /^\d+$/ && 0 < ${$/}) {
 188         # RECORD MODE
 189         goto &_not_implemented;
 190     }
 191     elsif (length $/ == 0) {
 192         # PARAGRAPH MODE
 193         goto &_not_implemented;
 194     }
 195     else {
 196         # LINE MODE
 197         goto &_not_implemented;
 198     }
 199 }
 200 sub getlines {
 201     my $self = shift;
 202     wantarray or _croak 'Must call getlines in list context';
 203     my @lines;
 204     while (defined (my $line = $self->getline)) {
 205         push @lines, $line;
 206     }
 207     return @lines;
 208 }
 209 sub ungetc {
 210     my ($self, $ord) = @_;
 211     unshift @{$self->_buffer_in}, chr($ord);
 212     return;
 213 }
 214 sub write {
 215     my ($self, $buf, $len, $offset) = @_;
 216     return $self->syswrite($buf, $len, $offset) == $len;
 217 }
 218 sub error {
 219     my $self = shift;
 220     return !!$self->_error;
 221 }
 222 sub clearerr {
 223     my $self = shift;
 224     my $fh = $self->_fh // return -1;
 225     $self->_error(undef);
 226     return;
 227 }
 228 sub sync {
 229     my $self = shift;
 230     my $fh = $self->_fh // return undef;
 231     return $fh->sync;
 232 }
 233 sub flush {
 234     my $self = shift;
 235     my $fh = $self->_fh // return undef;
 236     $self->_FLUSH($fh);
 237     return $fh->flush;
 238 }
 239 sub printflush {
 240     my $self = shift;
 241     my $orig = $self->autoflush;
 242     my $r = $self->print(@_);
 243     $self->autoflush($orig);
 244     return $r;
 245 }
 246 sub blocking {
 247     my $self = shift;
 248     my $fh = $self->_fh // return TRUE;
 249     return $fh->blocking(@_);
 250 }
 251
 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 }
 267
 268 ##############################################################################
 269
 270 sub _buffer_in_add      { push @{shift->_buffer_in}, @_ }
 271 sub _buffer_in_length   { sum0 map { length($_) } @{shift->_buffer_in} }
 272
 273 sub _buffer_out_add     { push @{shift->_buffer_out}, @_ }
 274 sub _buffer_out_length  { sum0 map { length($_) } @{shift->_buffer_out} }
 275
 276 sub _not_implemented    { _croak 'Operation not supported' }
 277
 278 ##############################################################################
 279
 280 sub TIEHANDLE {
 281     return $_[0] if is_blessed_ref($_[0]);
 282     die 'wat';
 283 }
 284
 285 sub UNTIE {
 286     my $self = shift;
 287 }
 288
 289 sub READLINE {
 290     goto &getlines if wantarray;
 291     goto &getline;
 292 }
 293
 294 sub binmode { 1 }
 295
 296 {
 297     no warnings 'once';
 298
 299     *READ = \&read;
 300     # *READLINE = \&getline;
 301     *GETC = \&getc;
 302     *FILENO = \&fileno;
 303     *PRINT = \&print;
 304     *PRINTF = \&printf;
 305     *WRITE = \&syswrite;
 306     # *SEEK = \&seek;
 307     # *TELL = \&tell;
 308     *EOF = \&eof;
 309     *CLOSE = \&close;
 310     *BINMODE = \&binmode;
 311 }
 312
 313 sub _FILL { die 'Not implemented' }
 314
 315 ##############################################################################
 316
 317 if ($ENV{DEBUG_IO}) {
 318     my %debug = (level => 0);
 319     for my $method (qw{
 320         new
 321         new_from_fd
 322         close
 323         eof
 324         fcntl
 325         fileno
 326         format_write
 327         getc
 328         ioctl
 329         read
 330         print
 331         printf
 332         say
 333         stat
 334         sysread
 335         syswrite
 336         truncate
 337
 338         autoflush
 339         format_page_number
 340         format_lines_per_page
 341         format_lines_left
 342         format_name
 343         format_top_name
 344         input_line_number
 345
 346         fdopen
 347         opened
 348         getline
 349         getlines
 350         ungetc
 351         write
 352         error
 353         clearerr
 354         sync
 355         flush
 356         printflush
 357         blocking
 358
 359         untaint
 360     }) {
 361         no strict 'refs'; ## no critic (ProhibitNoStrict)
 362         no warnings 'redefine';
 363         my $orig = *$method{CODE};
 364         *$method = sub {
 365             local $debug{level} = $debug{level} + 2;
 366             my $indented_method = (' ' x $debug{level}) . $method;
 367             my $self = shift;
 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";
 372             return $r;
 373         };
 374     }
 375 }
 376
 377 1;
 378 __END__
 379
 380 =begin Pod::Coverage
 381
 382 autoflush
 383 binmode
 384 close
 385 eof
 386 fcntl
 387 fileno
 388 format_lines_left
 389 format_lines_per_page
 390 format_name
 391 format_page_number
 392 format_top_name
 393 format_write
 394 getc
 395 input_line_number
 396 ioctl
 397 print
 398 printf
 399 read
 400 say
 401 stat
 402 sysread
 403 syswrite
 404 truncate
 405
 406 =end Pod::Coverage
 407
 408 =head1 DESCRIPTION
 409
 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:
 413
 414 =for :list
 415 * L<File::KDBX::IO::Crypt>
 416 * L<File::KDBX::IO::HashBlock>
 417 * L<File::KDBX::IO::HmacBlock>
 418
 419 =cut