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