view release on metacpan or  search on metacpan

lib/Mojo/Tar/File.pm  view on Meta::CPAN

    a100 # pos=0   name=name      desc=file name (chars)
    a8   # pos=100 name=mode      desc=file mode (octal)
    a8   # pos=108 name=uid       desc=uid (octal)
    a8   # pos=116 name=gid       desc=gid (octal)
    a12  # pos=124 name=size      desc=size (octal)
    a12  # pos=136 name=mtime     desc=mtime (octal)
    a8   # pos=148 name=checksum  desc=checksum (octal)
    a1   # pos=156 name=type      desc=type
    a100 # pos=157 name=symlink   desc=file symlink destination (chars)
    A6   # pos=257 name=ustar     desc=ustar
    a2   # pos=263 name=ustar_ver desc=ustar version (00)
    a32  # pos=265 name=owner     desc=owner user name (chars)
    a32  # pos=297 name=group     desc=owner group name (chars)
    a8   # pos=329 name=dev_major desc=device major number
    a8   # pos=337 name=dev_minor desc=device minor number
    a155 # pos=345 name=prefix    desc=file name prefix
    a12  # pos=500 name=padding   desc=padding (\0)
  );

  # Generate constants:
  # TAR_USTAR_NAME_LEN       TAR_USTAR_NAME_POS
  # TAR_USTAR_MODE_LEN       TAR_USTAR_MODE_POS
  # TAR_USTAR_UID_LEN        TAR_USTAR_UID_POS
  # TAR_USTAR_GID_LEN        TAR_USTAR_GID_POS
  # TAR_USTAR_SIZE_LEN       TAR_USTAR_SIZE_POS
  # TAR_USTAR_MTIME_LEN      TAR_USTAR_MTIME_POS
  # TAR_USTAR_CHECKSUM_LEN   TAR_USTAR_CHECKSUM_POS
  # TAR_USTAR_TYPE_LEN       TAR_USTAR_TYPE_POS
  # TAR_USTAR_SYMLINK_LEN    TAR_USTAR_SYMLINK_POS
  # TAR_USTAR_USTAR_LEN      TAR_USTAR_USTAR_POS
  # TAR_USTAR_USTAR_VER_LEN  TAR_USTAR_USTAR_VER_POS
  # TAR_USTAR_OWNER_LEN      TAR_USTAR_OWNER_POS
  # TAR_USTAR_GROUP_LEN      TAR_USTAR_GROUP_POS
  # TAR_USTAR_DEV_MAJOR_LEN  TAR_USTAR_DEV_MAJOR_POS
  # TAR_USTAR_DEV_MINOR_LEN  TAR_USTAR_DEV_MINOR_POS
  # TAR_USTAR_PREFIX_LEN     TAR_USTAR_PREFIX_POS
  # TAR_USTAR_PADDING_LEN    TAR_USTAR_PADDING_POS
  for my $line (split /\n/, $PACK_FORMAT) {
    my ($len, $pos, $name) = $line =~ /(\d+)\W+pos=(\d+)\W+name=(\w+)/ or next;

    my $const = uc "TAR_USTAR_${name}_LEN";
    constant->import($const => $len);
    push @EXPORT, $const;

    $const = uc "TAR_USTAR_${name}_POS";
    constant->import($const => $pos);
    push @EXPORT, $const;
  }
}

has asset => sub ($self) {Mojo::File::tempfile};
has checksum =>
  sub ($self) { substr $self->to_header, TAR_USTAR_CHECKSUM_POS, TAR_USTAR_CHECKSUM_LEN };
has dev_major   => '';
has dev_minor   => '';
has gid         => sub ($self) { $self->_stat('gid')  || $GID };
has group       => sub ($self) { getgrgid($self->gid) || '' };
has is_complete => sub ($self) { $self->_stat('size') == $self->size ? 1 : 0 };
has mode        => sub ($self) { ($self->_stat('mode') || 0) & 0777 };
has mtime       => sub ($self) { $self->_stat('mtime')   || time };
has owner       => sub ($self) { getpwuid($self->uid)    || '' };
has path        => sub ($self) { $self->asset->to_string || '' };
has size        => sub ($self) { $self->_stat('size')    || 0 };
has symlink     => '';
has type        => sub ($self) { $self->_build_type };
has uid         => sub ($self) { $self->_stat('uid') || $( };

sub add_block ($self, $block) {
  return $self unless $self->type eq 0;

  $self->{bytes_added} //= 0;
  my $chunk = substr $block, 0, $self->size - $self->{bytes_added};
  $self->{bytes_added} += length $chunk;
  croak 'File size is out of range' if $self->{bytes_added} > $self->size;

  my $handle = $self->{add_block_handle} //= $self->asset->open('>');
  ($handle->syswrite($chunk) // -1) == length $chunk or croak "Can't write to asset: $!";
  $self->is_complete(1)->_cleanup if $self->{bytes_added} == $self->size;

  warn sprintf "[tar:add_block] chunk=%s/%s size=%s/%s is_complete=%s path=%s\n", length($chunk),
    length($block), $self->{bytes_added}, $self->size, $self->is_complete, $self->path
    if DEBUG;

  return $self;
}

sub from_header ($self, $header) {
  my @fields   = unpack $PACK_FORMAT, $header;
  my $checksum = $self->_checksum($header);

  my ($prefix, $path) = map { _trim_nul($fields[$_]) } 15, 0;
  $path = Mojo::File->new($prefix, $path)->to_string if length $prefix;

  $self->path($path);
  $self->mode(_from_oct($fields[1]));
  $self->uid(_from_oct($fields[2]));
  $self->gid(_from_oct($fields[3]));
  $self->size(_from_oct($fields[4]));
  $self->mtime(_from_oct($fields[5]));
  $self->checksum($checksum eq $fields[6] =~ s/\0\s$//r ? $checksum : '');
  $self->type($fields[7] eq "\0"                        ? '0'       : $fields[7]);
  $self->symlink(_trim_nul($fields[8]));
  $self->owner(_trim_nul($fields[11]));
  $self->group(_trim_nul($fields[12]));
  $self->dev_major($fields[13]);
  $self->dev_minor($fields[14]);

  warn sprintf
    "[tar:from_header] path=%s mode=%s uid=%s gid=%s size=%s mtime=%s checksum=%s type=%s symlink=%s owner=%s group=%s\n",
    map { $self->$_ } qw(path mode uid gid size mtime checksum type symlink owner group)
    if DEBUG;

  return $self;
}

sub to_header ($self) {
  my ($name, $prefix) = (Mojo::File->new($self->path), '');
  ($name, $prefix) = ($name->basename, $name->dirname->to_string) if length($name) > 100;
  croak qq(path "@{[$self->path]}" is too long) if length($name) > 100 or length($prefix) > 155;

  my $header = pack $PACK_FORMAT, $name,    # 0