将 TCL 代码转换为 Perl答案

【问题标题】：Convert TCL code into Perl将 TCL 代码转换为 Perl
【发布时间】：2017-05-06 16:46:44
【问题描述】：

我有一个 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 {}
}

此过程采用 zip 文件名和 zip 中的文件扩展名（例如 .txt），还有其他文件也在 zip 中（例如 .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;
}

【问题讨论】：

我认为你需要更具体的重新。你目前在 Perl 中尝试过的
是的。包括您已有的 Perl 代码，这样我们就不会重做您的工作。
您正在尝试处理 zip 文件。 IO::Uncompress::Unzip 可能会有所帮助。
我分享我的代码请看我的尝试
@stackoverflow.com/users/667820/henk-langeveld 请看我的尝试。

标签： perl tcl

【解决方案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 命令是在编译时执行的，即使你把它们放在子程序中，所以你不妨把它们收集在代码的顶部。

【讨论】：