Question

我有一个TCL脚本，其中一个“proc”我要转换为Perl“Sub”，我不是tcl专家。我知道Perl但在proc中有一些命令是我无法转换为Perl的。

proc extract_from_zip_by_ext {zip ext} {
    set low_ext [string tolower $ext]

    foreach f [zipread_list $zip] {
        set filename [lindex $f 0]

        if {[string match -nocase "*.${ext}" $filename]} {

            #
            # We leave base alone rather than renaming it to
            # base.low_ext to make sure no other process uses
            # the same name.
            #
            set tmpname_base [::fileutil::tempfile]
            set tmpname "${tmpname_base}.${low_ext}"

            set filebytes [zipread_extract $zip $filename]

            set fp [open $tmpname w]
            fconfigure $fp -translation binary
            puts -nonewline $fp $filebytes
            close $fp

            file delete -force $tmpname_base
            return $tmpname
        }
    }

    return {}
}

这个proc取zip文件名和zip文件扩展名（ex .txt）还有其他文件也是zip（ex .doc）但是忽略那些文件只得到.txt和某处用原始文件创建的临时文件name写入所有zip文件的.txt文件中的所有内容并返回临时文件，以便我们可以访问其名称以及来自所有zip的所有.txt中的数据

以上逻辑是我从tcl中理解的，但有些我无法在Perl中解释

到目前为止我的尝试：

sub extract_from_zip_by_ext ($$){
    my($fileName, $ext) = @_;
    # say "$fileName $ext\n";
    use Archive::Zip qw( :ERROR_CODES ) ; 
    use File::Temp qw/ tempfile tempdir /;
    use Archive::Zip::MemberRead;
    use File::Basename;

    my @suffixlist = qw( HDR hdr zip ZIP) ;
    my $zip = Archive::Zip->new($fileName);
    my $unzipOutput;
    my ($dtgFname,$dtgFpath,$dtgFsuffix) = fileparse($fileName, @suffixlist);
    # say "$dtgFname\n";
    my $tmpname_base = new File::Temp( UNLINK => 1 );
    my $tmpname = ${dtgFname}.${ext};

    open FH, ">>", $tmpname or die "cant write $tmpname: $!\n";
    for my $member($zip->members){
        $unzipOutput = $member->fileName;       
        if($unzipOutput =~ /\.$ext$/i){ 
            my $fh = Archive::Zip::MemberRead->new($zip, $unzipOutput);          
            while (defined(my $line = $fh->getline())){
                say FH $line;
                # say "$tmpname\n";
                return ($tmpname, $line);
            }
        }
    }
    close FH;
}

Answer 1

这可能是更直接的翻译：未经测试：

use File::Temp          qw/ tempfile /;
use Archive::Zip        qw/ :ERROR_CODES /;
use Archive::Zip::MemberRead;
use autodie;

sub extract_from_zip_by_ext {
    my ($fileName, $ext) = @_;
    my @suffixlist = qw( HDR hdr zip ZIP ) ;
    my $zip = Archive::Zip->new($fileName);
    my $tmpname_base = new File::Temp( UNLINK => 1 );
    my $tmpname = "$tmpname_base.$ext";

    for my $member($zip->members) {
        my $memberFilename = $member->fileName;
        if ($memberFilename =~ /\.$ext$/i) {
            my $contents;
            my $fh = Archive::Zip::MemberRead->new($zip, $memberFilename);
            $fh->read($contents, $member->uncompressedSize);
            $fh->close();

            open my $ftmp, ">", $tmpname;
            print $ftmp $contents;
            close $ftmp

            return $tmpname;
        }
    }
}

由于您使用的是UNLINK => 1，因此从子网站返回时可能会删除您的文件。

注意use命令在编译时执行，即使你把它们放在子程序中，所以你也可以在代码的顶部收集它们。

将TCL代码转换为Perl

1 个答案: