Convert TCL code into Perl

Question

I have a TCL script in which one "proc" I want to convert into Perl "Sub", I'm not tcl expert. I know Perl but the in proc some commands are use which I cant convert into 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 {}
}

This proc takes zip file name and ext of file inside zip (ex .txt) there are other files are also in zip (ex .doc) but ignore those file and get only .txt and somewhere temp file created with original file name write all content from .txt files of all zip files and return temp file so we can access its name as well as data from all .txt from all zip

above logic is what I understand from tcl but some how I couldn't interpret in Perl

My try so far:

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;
}

I think you need to be much more specific re. what you've currently tried in Perl — Brian Agnew
Yes. Include the Perl code you already have so we don't redo your work. — simbabque
You're trying to process zip files. IO::Uncompress::Unzip might help. — Henk Langeveld
@stackoverflow.com/users/667820/henk-langeveld please see my attempt. — Prashant Deore

glenn jackman glenn jackman · Accepted Answer · 2016-12-21T23:17:25

This may be a more direct translation: untested:

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;
        }
    }
}

Since you're using UNLINK => 1, your file is probably deleted when you return from the sub.

Note the use commands are executed at compile time, even if you put them in a subroutine, so you might as well collect them at the top of the code.

Convert TCL code into Perl

1 Answers