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