File Coverage

lib/Archive/Lha/Header/Base.pm

Criterion	Covered	Total	%
statement	55	63	87.3
branch	15	22	68.1
condition	12	16	75.0
subroutine	12	13	92.3
pod	3	3	100.0
total	97	117	82.9

package Archive::Lha::Header::Base;

use strict;
use warnings;
use Carp;
use File::Spec;
use File::Spec::Unix;

sub import {
  my $class  = shift;
  my $caller = caller;

  my @accessors = qw(
    method header_top data_top next_header
    encoded_size original_size crc16 timestamp os
  );

  {
    no strict 'refs'; no warnings 'redefine';
    foreach my $name ( @accessors ) {
      *{"$class\::$name"} = sub { shift->{$name} };
    }
    push @{"$caller\::ISA"}, $class;
  }
}

# Map OS identifier to the most likely filename encoding used by that platform.
my %_os_charset = (
  'a' => 'iso-8859-15',  # Amiga
  'M' => 'cp1252',       # MS-DOS / Windows
  'w' => 'cp1252',       # WinNT / Win95
  'U' => 'guess',        # Unix (encoding varies: UTF-8 on modern, latin-1 on older)
  'H' => 'cp932',        # Human68K (Sharp X68000)
  'J' => 'cp932',        # Java VM (often used with Japanese archives)
  'm' => 'UTF-8',        # Macintosh (modern)
);

sub charset_for_os {
  my ($self) = @_;
  my $os_id = $self->{os} ? $self->{os}[0] : undef;
  return $os_id && $os_id ne '?' ? ( $_os_charset{$os_id} // 'guess' ) : 'guess';
}

sub pathname {
  my ($self, $from, $to) = @_;
  my $path;
  if ( $self->{pathname} ) {
    $path = _conv_sep( $self->{pathname} );
  }
  elsif ( $self->{directory} && $self->{filename} ) {
    $path = File::Spec::Unix->catfile(
      _conv_sep( $self->{directory} ),
      _conv_sep( $self->{filename} )
    );
  }
  elsif ( $self->{filename} ) {
    $path = _conv_sep( $self->{filename} );
  }
  elsif ( $self->{directory} ) {
    $path = _conv_sep( $self->{directory} . '/' );
  }

  # avoid traversal
  if ( File::Spec::Unix->file_name_is_absolute( $path ) ) {
    my ($vol, $dir, $file) = File::Spec::Unix->splitpath( $path );
    $path = File::Spec::Unix->catfile( '.', $dir, $file );
  }

  # default from-encoding: auto-detect from OS field
  $from //= $self->charset_for_os;
  $to   //= 'UTF-8';

  require Encode;
  if ( lc $from eq 'guess' ) {
    require Encode::Guess;
    my $enc = Encode::Guess::guess_encoding(
      $path => qw( latin1 latin2 cp932 euc-jp )
    );
    Encode::from_to( $path, ref($enc) ? $enc->name : 'latin1', $to );
  }
  elsif ( lc $from ne lc $to ) {
    Encode::from_to( $path, $from, $to );
  }

  my $trailing_slash = $path =~ m{/$};
  $path = File::Spec::Unix->canonpath( $path );
  $path .= '/' if $trailing_slash && $path !~ m{/$};
  return $path;
}

sub dirname {
  my $self = shift;
  my $path = $self->pathname(@_);
  require File::Basename;
  return  File::Basename::dirname( $path );
}

sub _conv_sep {
  my $path = shift;

  $path =~ s{\xff|\\}{/}g;
  return $path;
}

1;

__END__