@rem = '--*-Perl-*--
@echo off
if "%OS%" == "Windows_NT" goto WinNT
perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
:WinNT
perl -x -S "%0" %*
if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
if %errorlevel% == 9009 echo You do not have Perl in your PATH.
goto endofperl
@rem ';
#!perl
# dpm.pl V0.04 Dynamic Package Manager
# Copyright (c) 2000 Indy Singh/IndigoSTAR Software all rights reserved



BEGIN {
    $| = 1;
    open (STDERR, ">&STDOUT");
}


use strict;
use ExtUtils::Install ();
use Config;
use File::Path; # mkpath, rmtree
use File::Basename;
use File::Copy ();
use Getopt::Long;
use Pod::Html;
use Cwd;
$^W = 1;    # turn on warnings, can't use before use ExtUtils::Install ();
eval ("use Archive::Tar;");
print "Warning: Archive::Tar not available\n" if $@;
eval ("use LWP::UserAgent;");
print "Warning: LWP::UserAgent not available\n" if $@;
eval ("use LWP::Simple;");
print "Warning: LWP::Simple not available\n" if $@;



# DPM CONFIG BEGIN
my $verbose = 1;
my $dpmcachedir = "$Config{'prefix'}/dpmcache";
my $dpmdatadir = "$Config{'prefix'}/dpm";
my $osname = "MSWin32";
# DPM CONFIG END

my @repository_list = split("\n", ReadFile("$dpmdatadir/repository_list.txt"));
@repository_list = (
        "Local Repository = local_repository" ,
        "ActiveState = http://www.activestate.com/packages",
        "Jenda's Packages = http://Jenda.Krynicky.cz/perl",
        "CPAN = http://www.perl.com/CPAN-local",
        ) if !(@repository_list);


sub dpm_Getsave_location
{
    my $save_location = ReadFile("$dpmdatadir/save_location.txt") ||
        "local_repository";
    return $save_location;
}

sub dpm_Savesave_location
{
    WriteFile("$dpmdatadir/save_location.txt", $_[0]);
}


sub dpm_GetRepositoryList
{
    return @repository_list;
}

sub dpm_SaveRepositoryList
{
    WriteFile("$dpmdatadir/repository_list.txt", join("\n", @_));
}


my $makecmd = $Config{'make'};

return 1 if (caller());

my $nono = 0;   # don't really do it
my $location = "";
my $debug = 0;
my $listpath = 0;
my $save_location = "";
GetOptions("location=s" => \$location, "debug" => \$debug, 
            "listpath" => \$listpath, "save_location=s" => \$save_location) || exit 0;
$location =~ s/[\/\\]$//g if $location;
$save_location =~ s/[\/\\]$//g if $save_location;


if (@ARGV == 0) {
    usage();
    exit;
}
my $command = shift @ARGV;
if ($command eq "install" ) {
    my $doinstall = 1;
    InstallPackages($doinstall, $save_location, @ARGV);
}
elsif ($command eq "save" ) {
    my $doinstall = 0;
    InstallPackages($doinstall, $save_location, @ARGV);
}
elsif ($command =~ "search|list") {
    dpm_ListPackages(@ARGV);
}
elsif ($command =~ "remove") {
    RemovePackages(@ARGV);
}
elsif ($command =~ "query") {
    dpm_ListInstalledPackages(@ARGV);
}
elsif ($command =~ "maketoc") {
    MakeTOC();
}
elsif ($command =~ "makehtml") {
    MakeHTML();
}
elsif ($command =~ "makemod") {
    MakeMod(@ARGV);
}
elsif ($command =~ "makepackage") {
    MakePackage(@ARGV);
}
elsif ($command eq "testloop") {
    print "command = test, location = $location, args = ", join(" ", @ARGV), "\n";
    my $i;
    for ($i=0; $i < 5; $i++) {
        print "Log $i " . scalar(localtime()) . "\n";
        sleep 1;
    }
    print "DONE\n";
}
elsif ($command eq "test") {
    Test();
}
elsif ($command eq "import") {
    ImportPPMXML();
}
else {
    print "Error: Invalid command $command\n";
    exit 1;
}




#### M A K E ##################################################################



sub ImportPPMXML
{
    print "Inporting package list from ppm.xml\n";

    my ($data) = ReadFile("$Config{'prefix'}/site/lib/ppm.xml");
    if (!$data) {
        print "ERROR: ppm.xml not found or is empty\n";
    }

    my $pkgdata = ReadFile("$dpmdatadir/installed_packages.txt");
    my @lines = split("\n", $pkgdata);


    my @nv = $data =~/<SOFTPKG NAME=\"(.*?)\" VERSION=\"(.*?)\">/g;
    my ($i, $package_name, $v);
    for($i=0; $i < @nv; $i += 2) {
        $package_name = $nv[$i];
        $v = $nv[$i+1];
        while($v =~ s/,0$//) { 1; }
        $v =~ s/,/./g;
        my $package_description = "$package_name [$v]";
        print "$package_description\n";

        # remove matching package name if found ignoring version number
        @lines = grep(!/^$package_name \[.*\]/, @lines);
        push(@lines, $package_description);
    }

    @lines = sort {uc($a) cmp uc($b)} @lines;
    $data = join("\n", @lines);
    mkpath($dpmdatadir, 0, 755) if (!-d $dpmdatadir);
    WriteFile("$dpmdatadir/installed_packages.txt", $data) unless $nono;
}





sub MakePackage
{
    # make ppd and blib tar.gz file
    my @pathlist = @_;
    my @rc;

    my $starting_dir = getcwd();

    while (@pathlist) {
        my $path = shift @pathlist;
        print "Making package $path\n";
        chdir($starting_dir);
        if (-d $path) {
            chdir $path;
            echosys("nmake -nologo ppd");

            my ($ppdfile) = scan_dir(".", '\\.ppd$');
            my $ppddata = ReadFile($ppdfile);

            my ($package_name) = $ppddata =~ m/NAME=\"(.*?)\"/i;
            my ($package_version) = $ppddata =~ m/VERSION=\"(.*?)\"/i;
            while($package_version =~ s/,0$//) { 1; }
            $package_version =~ s/,/./g;
            my $tarfile = "$package_name-$package_version.tar.gz";
            push (@rc, $ppdfile, $tarfile);

            $ppddata =~ s/(CODEBASE HREF=\")/$1$tarfile/s;
            WriteFile($ppdfile, $ppddata);
            print "Writing tarfile $tarfile\n";
            my $tar = Archive::Tar->new();
            my @files = scan_dir("blib");
            #print "file:\n", join("\n", @files);
            $tar->add_files(@files);
            $tar->write($tarfile, 1);
            #system("tar cvf $package_name-PPM.tar blib");
            #system("gzip --best $package_name-PPM.tar");
            chdir "..";
        }
        else {
            print "ERROR: Don't know how to make package $path\n";
        }
    } #while
    return @rc;
}


sub _build_html
{
    my @files = scan_dir("blib", '(\\.pod)|(\\.pm)$');
    my $f;
    foreach $f (@files) {
        $f =~ s%blib/%%;
        my $outfile;
        ($outfile = $f) =~ s/(\.pod)|(\.pm)$/.html/i;
        print ("$f => html/$outfile\n");
        my $outdir;
        $outdir = "./blib/html/$outfile";
        $outdir =~ s#/[^/]+$##;
        mkpath($outdir, 0, 0777);
        Pod::Html::pod2html("--htmlroot=/", "--htmldir=./blib/html",
                    "--quiet",
                    "--header", "--podroot=.", "--index",
                    "--infile=./blib/$f",
                    "--outfile=./blib/html/$outfile");
    }
}



sub MakeMod
{
    my @pathlist = @_;
    # build a CPAN module input can be a directory or a tar.gz file
    my $rc = 0;

    my $starting_dir = getcwd();
    while (@pathlist) {
        my $path = shift @pathlist;
        chdir($starting_dir);
        print "Making module $path\n";
        if (-f $path && $path =~ m/\.tar\.gz$/) {
            my $tarfile = $path;
            print "Exploding tarfile $tarfile\n";
            my $tar = Archive::Tar->new();
            $tar->read($tarfile,1);
            my @filenames = $tar->list_files();
            $path =~ s/\.tar\.gz$//;
            rmtree($path);
            $tar->extract(@filenames);
        }

        $path =~ s/\.tar\.gz$//;
        if (-d $path) {
            chdir $path;
            $rc += echosys("$Config{'perlpath'} Makefile.PL") if (!-e "Makefile");
            $rc += echosys("nmake -nologo");
            #echosys("$Config{'perlpath'} e:\\perl\\build\\installhtml --podroot=blib --podpath=lib --htmldir=blib\\html --recurse");
            _build_html();
            chdir "..";  # this allows you to say makemod dir1 dir2 ..
        }
        else {
            print "Don't know how to make module $path\n";
        }
    } #while
    return $rc;
}



sub scan_dir {
    my($dir, $pattern) = @_;
    my @subdirs = $dir;
    my(@files, $e);

    while (@subdirs) {
        $dir = shift @subdirs;
        opendir(DIR, $dir) || die "$0: error opening directory $dir: $!\n";
        while (defined($e = readdir(DIR))) {
            if ($e eq "." || $e eq "..") {  # directory
            }
            elsif (-d "$dir/$e") {  # directory
                push(@subdirs, "$dir/$e");
            } elsif ((!$pattern) || $e =~ /$pattern/) {     # .pod or .pm
                push(@files, "$dir/$e");
            }
        }
    }
    closedir(DIR);
    return sort @files;
}




sub echosys
{
    my ($cmd) = @_;
    # print command, then call system

    print "$cmd\n";
    my $rc = system($cmd);
    $rc = $rc >> 8;
    if ($rc) {
        print "ERROR: returned by command\n";
        return $rc;
    }
    return 0;
}


sub MakeHTML
{
    # rebuild all HTML files
    print "Making all HTML files\n";

    chdir $Config{'prefix'};
    my $cmd = "$Config{'perlpath'} build\\installhtml " .
            "--verbose --podroot=. --htmldir=./html --podpath=site:lib " .
            "--libpod=perlfunc,perlguts,perlvar,perlrun,perlop --recurse";
    system($cmd);
}


sub MakeTOC
{
    print "Making TOC\n";
    # make table of contents page for currently installed html files
    # updates perltoc.html

    my ($cwd, @dir, @pod, @modules, $filename);
    my ($desc, $line);

    chdir $Config{'installhtmldir'};
    $cwd = $Config{'installhtmldir'}; $cwd =~ s/\\/\\\\/g;
    #@dir = `dir *.html /s/b/a-d`;
    #chomp @dir;
    @dir = scan_dir($Config{'installhtmldir'}, '\\.html$');
    #print "HTML FILES:\n", join("\n", @dir), "\n";

    foreach $filename (@dir) {
        $filename =~ s%/%\\%g;
        $filename =~ s/^$cwd\\//i;
        next if ($filename !~ m/^(lib\\)|(site\\lib\\)/i);   # skip files in root of html directory

        #G:\perl56i\html/site/lib/DBI.html
        #G:\perl56i\html/site/lib/Bundle/LWP.html
        #G:\perl56i\html/lib/Symbol.html
        #G:\perl56i\html/lib/Pod/perlembed.html
        #G:\perl56i\html/lib/Pod/Win32.html

        $desc = $filename;
        $desc =~ s/^site\\lib\\//i;
        $desc =~ s/^lib\\//i;
        $desc =~ s/^pod\\//i;
        $desc =~ s/\\/::/g;
        $desc =~ s/\.html$//i;

        # put description at start so we can sort it.
        my $fileurl = $filename;
        $fileurl =~ s%\\%/%g;
        $line = "$desc %%%% <a href=\"$fileurl\">$desc<\/a><br>\n";

        if ($filename =~ /^lib\\pod/i) {
            push(@pod, $line);
        } else {
            push(@modules, $line);
        }
    } # foreach

    @pod = sort {uc($a) cmp uc($b)} @pod;
    @pod = map { (/.* %%%% (.*)/s)[0]  }  @pod;
    @modules = map { (/.* %%%% (.*)/s)[0]  } sort {uc($a) cmp uc($b)} @modules;

    my $data = ReadFile("perltoc.html");
    my ($header, $footer) = $data =~ m/(^.*<!--BEGIN TOC-->).*(<!--END TOC-->.*)/s;

    $data = "<h4><a name=\"CorePerlDocs\">Core Perl Docs</a></h4>\n";
    $data .= join("\n", @pod);
    $data .= "<h4><a name=\"ModuleDocs\">Module Docs</a></h4>\n";
    $data .= join("\n", @modules);

    WriteFile("perltoc.html", $header . $data . $footer);
}






#### L I S T ##################################################################


sub dpm_ListInstalledPackages
{
    my $data = ReadFile("$dpmdatadir/installed_packages.txt");
    print "#Installed packages\n";
    print "$data\n";
}



sub dpm_ListPackages
{
    my @pathlist = @_;
    # list of repositories to be searched, directories or URL

    # use $Location or @ARGV, or repositories
    unshift(@pathlist, $location) if $location;
    @pathlist = @repository_list if (!@pathlist);

    my $starting_dir = getcwd();
    while (@pathlist) {
        chdir($starting_dir);
        my $path = shift @pathlist;
        $path =~ s/[\/\\]$//;   # remove any trailing slash

        my $name = $path;
        if ($path=~ m/(.*)\s*=\s*(.*)/) {
            ($name,$path) = $path=~ m/(.*)\s*=\s*(.*)/;
            # relative paths can be relative to 'prefix'
            if (!-d $path && -d "$Config{'prefix'}/$path") {
                $path = "$Config{'prefix'}/$path";
            }
        }

        print "#Packages at $path:\n";
        # directory or UNC    
        if (-d $path || $path =~ /^\\\\/ || $path =~ /^\/\//) {
            ListDirectoryPackages($path);
        }
        else {
            ListURLPackages($path);
        }
    } #while
}



sub ListDirectoryPackages
{
    my ($path) = @_;
    # package.lst, *.ppd. */blib, *.tar.gz, CPAN/modules/02packages.details.txt

    print "Packages in $path/package.lst:\n" if $debug;
    my $data;
    if (-f "$path/package.lst") {
        $data = ReadFile("$path/package.lst");
        ParseSummaryFile($data);
        return unless $debug;
    }

    print "Packages in $path/*.ppd files:\n" if $debug;
    my ($file);
    my @files;
    opendir(PPDDIR, $path) or die;
    @files = grep { /\.ppd$/i && -f "$path/$_" } readdir(PPDDIR);
    close (PPDDIR);
    @files = sort @files;
    foreach $file (@files) {
        #$file =~ s/\.ppd//i;

        my $ppddata;
        if (!($ppddata = ReadFile("$path/$file"))) {
            print "Error: Could not read $path/$file\n";
            next;
        }
        my ($package_name) = $ppddata =~ m/NAME=\"(.*?)\"/i;
        my ($package_version) = $ppddata =~ m/VERSION=\"(.*?)\"/i;
        while($package_version =~ s/,0$//) { 1; }
        $package_version =~ s/,/./g;
        my $package_description = "$package_name [$package_version]";
        print "$package_description\n";
    }
    return if (@files && !$debug);

    
    print "Packages in $path/*/blib directories:\n" if $debug;
    opendir(PPDDIR, $path) or die;
    @files = grep {-d "$path/$_/blib" } readdir(PPDDIR);
    close (PPDDIR);
    @files = sort @files;
    foreach $file (@files) {
        $file =~ s/^(.*)-([\d\.]+)$/$1-$2 [$2]/s;
        print "$file\n";
    }
    return if (@files && !$debug);

    if (-e "$path/modules/02packages.details.txt.gz") {
        print "Packages at CPAN site $path:\n" if $debug;
        if ($data = FetchCPANIndexFile($path) ) {
            ParseCPANFile($data);
        }
        return unless $debug;
    }


    print "Packages in $path/*.tar.gz files:\n" if $debug;
    opendir(PPDDIR, $path) or die;
    @files = grep { /\.tar\.gz$/i && -f "$path/$_" } readdir(PPDDIR);
    close (PPDDIR);
    @files = sort @files;

    foreach $file (@files) {
        $file =~ s/\.tar\.gz//i;
        $file =~ s/^(.*)-([\d\.]+)$/$1 [$2]/s;
        $file =~ s/^(.*)-([\d\.]+)-PPM$/$1 [$2]/is;
        print "$file\n";
    }
}




sub ListURLPackages
{
    my ($path) = @_;
    my $data;

    # package.lst ,default.prk?list=1, CPAN/modules/02packages.details.txt, ppd's

    print "Packages in $path/package.lst:\n" if $debug;
    if ($data = ReadURL("$path/package.lst")) {
        ParseSummaryFile($data);
        return unless $debug;
    }

    print "Packages in $path/default.prk?list=1:\n" if $debug;
    if ($data = ReadURL("$path/default.prk?list=1")) {
        ParsePRKList($data);
        return unless $debug;
    }

    if ($path =~ /CPAN$/ || $path =~ /CPAN-local$/) {
        print "Packages at CPAN site $path:\n" if $debug;
        if ($data = FetchCPANIndexFile($path) ) {
            ParseCPANFile($data);
        }
        return unless $debug;
    }

    # we won't pass here normally
    # we could fetch ppd to get name and version, but it would take a while
    print "Packages in $path/*.ppd files:\n" if $debug;
    $data = ReadURL("$path/");
    return if (!$data);

    my @ppds;
    if ($data =~ /^<head><title>/) {
        print "IIS format directory listing\n" if $debug;
        @ppds = grep { /\.ppd/i } split('<br>', $data);
        @ppds = sort @ppds;
        my $file;
        foreach $file (@ppds) {
            $file =~ s/\.ppd<.*$//is;
            $file =~ s@.*>@@is;
            print "$file\n";
        }
    }
    else {
        print "Apache format directory listing\n" if $debug;
        @ppds = grep { /\.ppd/i } split('\n', $data);
        @ppds = sort @ppds;
        my $file;
        foreach $file (@ppds) {
            $file =~ s/^.*>(.*?)\.ppd<.*$/$1/i;
            print "$file\n";
        }
    }
}







#### R E M O V E ##############################################################

sub RemovePackages
{
    my @packagelist = @_;
    my $packlist;

    while (@packagelist) {
        my $f = shift @packagelist;

        my $package_name = $f;
        my $data = ReadFile("$dpmdatadir/installed_packages.txt");
        my @lines = split("\n", $data);
        # find matching package name ignoring version number
        if (!grep(/^$package_name \[.*\]/, @lines)) {
            print "Error: Package $f is not installed\n";
            next;
        }
        my ($match) = grep(/^$package_name \[.*\]/, @lines);
        print "Removing package $match\n";

        $packlist = "$dpmdatadir/$f.packlist";
        if (!-f $packlist) {
            print "Error: packlist ($packlist) for package $f not found\n";
            next;
        }


        # remove matching package name if found ignoring version number
        @lines = grep(!/^$package_name \[.*\]/, @lines);
        @lines = sort @lines;
        $data = join("\n", @lines);
        WriteFile("$dpmdatadir/installed_packages.txt", $data) unless $nono;

        # clean up any files that do not exist
        # otherwise uninstal will bomb
        my @packlistdata = split("\n", ReadFile($packlist));
        my $foo;
        my @newpacklistdata;
        foreach $foo (@packlistdata) {
            push(@newpacklistdata, $foo) if (-e $foo);
        }
        WriteFile($packlist, join("\n", @newpacklistdata));

        ExtUtils::Install::uninstall($packlist, $verbose, $nono);
        rmdir("$dpmdatadir/$f");
    }
    MakeTOC();
    print "DONE\n";
}


#### I N S T A L L ############################################################


sub InstallPackages
{
    # list of packages to be installed, directories or filenames
    # name is a relative or abs filepath, or url 
    # name is a ppd or tar.gz file or blib dir
    # for local files the tar.gz extension can be omitted

    my ($doinstall, $save_location, @filelist) = @_;

    my $starting_dir = getcwd();

    mkpath($dpmcachedir, 0, 755) if (!-d $dpmcachedir);
    if ($save_location && !-d $save_location) {
        print "ERROR: save_location '$save_location' is invalid\n";
        print "DONE\n";
        return;
    }
    $save_location = Cwd::abs_path($save_location) if $save_location;

    while (@filelist) {
        chdir($starting_dir);
        my $f = shift @filelist;
        $f = "$location/$f" if $location;
        $f = expand_cpan_path($f);

        if (-f $f && $f =~/\.ppd$/) {
            InstallPPDfile($f, $doinstall, $save_location);
        }
        elsif (-f "$f.ppd") {
            InstallPPDfile("$f.ppd", $doinstall, $save_location);
        }
        elsif (-d "$f/blib" ) {
            # directory containing blib subdirectory
            # TODO get name and version from Makefile if available
            InstallBlib($f, get_name_description($f));
        }
        elsif (-d $f && -f "$f/Makefile.PL") {
            # directory containing cpan source files
            MakeMod($f);
            # TODO get name and version from Makefile if available
            InstallBlib($f, get_name_description($f));
        }
        elsif (-f $f && $f =~/\.tar\.gz$/) {
            InstallTarfile($f, get_name_description($f), $doinstall, $save_location);
        }
        elsif (-f "$f.tar.gz") {
            InstallTarfile("$f.tar.gz", get_name_description("$f.tar.gz"), $doinstall, $save_location);
        }
        elsif ($f =~ m%^(http://)|(ftp://)%i && $f =~/\.tar\.gz$/) {
            # remote tar file
            # fetch tarfile to local cache
            my ($tarfilename) = basename($f);
            if (!ReadURL($f, "$dpmcachedir/$tarfilename")) {
                print "Error: Could not fetch $f\n";
                next;
            }
            InstallTarfile("$dpmcachedir/$tarfilename", get_name_description($tarfilename), $doinstall, $save_location);
        }
        elsif ($f =~ m%^(http://)|(ftp://)%i) {
            # a url to a ppd file with or without the .ppd extension
            # if a url, then fetch ppd and tar file to cache
            # url must point to a ppd file
            print "Downloading Package $f\n";
            $f .= ".ppd" if ($f !~ /\.ppd$/);
            my ($basename,$path) = fileparse($f);
            my $ppddata;
            if (!($ppddata = ReadURL($f))) {
                print "Error: Could not fetch $f\n";
                next;
            }

            # tar filepath may be absolute or relative
            my ($tarfilepath) = $ppddata =~ m/OS NAME=\"$osname\".*?CODEBASE HREF=\"(.*?)\"/is;
            my ($tarfilename) = basename($tarfilepath);

            my $tarurl;
            $tarurl = ($tarfilepath =~ m%^(http://)|(ftp://)|(.:)%i) ? $tarfilepath : "$path$tarfilepath";
            if (!ReadURL("$tarurl", "$dpmcachedir/$tarfilename")) {
                print "Error: Could not fetch $tarurl\n";
                next;
            }
            # ppd file must me modified because we need to strip the tarfile path
            # i.e <CODEBASE HREF="x86/File.tar.gz" -> <CODEBASE HREF="file.tar.gz"
            $ppddata =~ s/(OS NAME=\"$osname\".*?CODEBASE HREF=)\"(.*?)\"/$1\"$tarfilename\"/is;
            WriteFile("$dpmcachedir/$basename", $ppddata);
            InstallPPDfile("$dpmcachedir/$basename", $doinstall, $save_location);
        }
        else {
            print "Error: Don't know how to install $f\n";
        }
    }

    MakeTOC() if ($doinstall);
    print "DONE\n";
}



sub InstallPPDfile
{
    my ($PPDfile, $doinstall, $save_location) = @_;
    print "Installing PPDfile: $PPDfile\n" if $debug;
    my ($foo, $path) = fileparse($PPDfile);

    my $ppddata = ReadFile($PPDfile);
    my ($reltarfile) = $ppddata =~ m/CODEBASE HREF=\"(.*?)\"/i;
    my ($package_name) = $ppddata =~ m/NAME=\"(.*?)\"/i;
    my ($package_version) = $ppddata =~ m/VERSION=\"(.*?)\"/i;
    if (!$reltarfile) {
        print "ERROR: Invalid ppd file\n";
        die;
    }
    while($package_version =~ s/,0$//) { 1; }
    $package_version =~ s/,/./g;
    my $package_description = "$package_name [$package_version]";

    if ($doinstall) {
        InstallTarfile("$path/$reltarfile", $package_name, $package_description, $doinstall, $save_location);
    }
    if ($save_location) {
        File::Copy::copy($PPDfile, $save_location);
        InstallTarfile("$path/$reltarfile", $package_name, $package_description, $doinstall, $save_location);
    }
}




sub InstallTarfile
{
    my ($tarfile, $package_name, $package_description, $doinstall, $save_location) = @_;
    print "DBG: Installing tarfile: $tarfile, $package_name, $package_description\n" if $debug;
    my ($subdir) = basename($tarfile, ".tar.gz");

    print "DBG: Extracting tarfile to $dpmcachedir/$subdir\n" if $debug;
    my $tar = Archive::Tar->new();
    $tar->read($tarfile,1);
    my @filenames = $tar->list_files();

    if (grep(/^blib\//, @filenames)) {
        # remove subdir to prevent errors during extract
        rmtree("$dpmcachedir/$subdir", 0) if (-d "$dpmcachedir/$subdir");
        mkpath("$dpmcachedir/$subdir", 0, 0755);
        chdir("$dpmcachedir/$subdir");
        $tar->extract(@filenames);
        _build_html();  # v5.5 contains html, V5.6 does not
        if ($doinstall) {
            InstallBlib("$dpmcachedir/$subdir", $package_name, $package_description)
        }
        if ($save_location) {
            print "Saving package to $save_location\n";
            File::Copy::copy($tarfile, $save_location);
        }
    }
    elsif (grep(/^([^\/]+)\/Makefile.PL/, @filenames)) {
        print "Tar contains a CPAN source module $subdir\n";
        chdir("$dpmcachedir");
        # remove subdir to prevent errors during extract
        rmtree("$dpmcachedir/$subdir", 0) if (-d "$dpmcachedir/$subdir");
        $tar->extract(@filenames);
        my $rc = MakeMod($subdir);
        print "Errors during make\n" if ($rc);
        if ($doinstall) {
            InstallBlib("$dpmcachedir/$subdir", $package_name, $package_description);
        }
        if ($save_location) {
            my ($ppdfile, $pkgtarfile) = MakePackage($subdir);
            print "Saving package to $save_location\n";
            File::Copy::copy("$subdir/$ppdfile", $save_location);
            File::Copy::copy("$subdir/$pkgtarfile", $save_location);
        }
    }
    else {
        print "#Invalid tar file\n";
    }
}


sub InstallBlib
{
    my ($blibdir, $package_name, $package_description) = @_;
    # input directory containing blib subdirectory
    print "Installing Package $package_description from directory $blibdir\n" if $debug;
    print "Installing package $package_description\n";

    mkpath($dpmdatadir, 0, 755) if (!-d $dpmdatadir);

    my %copylist = ("$blibdir/blib/lib" => $Config{'installsitelib'},
                    "$blibdir/blib/arch" => $Config{'installsitearch'},
                    "$blibdir/blib/bin" => $Config{'installbin'},
                    "$blibdir/blib/script" => $Config{'installscript'},
                    "$blibdir/blib/Html" => $Config{'installhtmldir'},
                    "$blibdir/blib/HtmlHelp" => $Config{'installhtmlhelpdir'},
                    "read" => "$dpmdatadir/$package_name.packlist",
                    "write" => "$dpmdatadir/$package_name.packlist",
                    );

    ExtUtils::Install::install(\%copylist, $verbose, $nono);

    my $data = ReadFile("$dpmdatadir/installed_packages.txt");
    my @lines = split("\n", $data);
    # remove matching package name if found ignoring version number
    @lines = grep(!/^$package_name \[.*\]/, @lines);
    push(@lines, $package_description);
    @lines = sort {uc($a) cmp uc($b)} @lines;
    $data = join("\n", @lines);
    WriteFile("$dpmdatadir/installed_packages.txt", $data) unless $nono;
    # run the install script if there is one
    system("$Config{'perlpath'} $blibdir/install.ppm") if (-e "$blibdir/install.ppm" && !$nono);
}




sub get_name_description
{
    # get name and description from filename
    my ($f) = @_;
    $f =~ s/\.tar\.gz//;
    my ($package_name) = basename($f);
    my $package_description = basename($f);
    if ($f =~ /(.*?)-([\d\.]+)$/) {
        my $package_version = "";
        ($package_name, $package_version) = $f =~ /(.*?)-([\d\.]+)$/;
        $package_name = basename($package_name);
        $package_description = "$package_name [$package_version]";
    }
    return ($package_name, $package_description);
}


sub expand_cpan_path
{
    my ($f) = @_;

    my ($filename, $path, $subdir);
    # get the immediate parent directory of filepath
    ($filename, $path) = fileparse($f);
    #print "filename = $filename, path = $path\n";
    $path =~ s%/$%%;    # it will be ./ if no path

    ($subdir) = basename($path); #todo use dirname($);
    #print "subdir = $subdir\n";


    if ($subdir =~ /CPAN/i || $subdir =~ /CPAN-local/i) {
        my $data;
            if ($data = FetchCPANIndexFile($path) ) {
            my ($m, $v, $p, $x);
            $data =~ s/.*?\n\n//s;  # chop off header
            my @lines = split("\n", $data);

            my %files = ();
            my ($line);    
            foreach $line (@lines) {
                $m = "";
                ($v, $m) = $line =~ m/[^\s]+\s+([^\s]+)\s+([^\s]+)/;
                my ($p, $x) = $m =~ m%(.*)/([^/]+)%;
                $files{$x} = $m;
                last if ($filename eq $x);
            }
            $f = $files{$filename} ? "$path/authors/id/$files{$filename}" : $f;
            print "DBG: Expandef CPAN path = $f\n" if $debug;
            return $f;
        }
    }
    else {
        return $f;
    }
}










#### U T I L ##################################################################



sub ReadURL
{
    my ($url, $targetfile) = @_;
    $targetfile = "" if !$targetfile;
    print "DBG: ReadURL: url = $url, targetfile = $targetfile\n" if $debug;

    my $ua = new LWP::UserAgent;
    if (defined $ENV{HTTP_proxy}) {
        $ua->env_proxy;
    }

    my $req = new HTTP::Request "GET" => $url;

    my $proxy_user = $ENV{HTTP_proxy_user};
    my $proxy_pass = $ENV{HTTP_proxy_pass};
    if (defined $proxy_user && defined $proxy_pass) {
        $req->proxy_authorization_basic("$proxy_user", "$proxy_pass");
    }

    my $username;   # TBD
    my $password;   # TBD
    if (defined $username && defined $password) {
        $req->authorization_basic($username, $password);
    }

    my $res = $ua->request($req);

    if ($res->is_success) {
        if ($targetfile) {
            if (!open(OUT, ">$targetfile")) {
                print "Couldn't open $targetfile for writing\n";
                return undef;
            }
            binmode(OUT);
            print OUT $res->content;
            close(OUT);
        }
        return $res->content;
    } else {
        return undef;
    }
}



sub ReadFile   # (filename)
{
    # read file in ascii mode
    my ($filename, $binmode) = @_;
    my ($data);
    open (IN, $filename) || return "";
    binmode IN if ($binmode);
    read (IN, $data, (-s IN));
    close IN;
    return $data;
}


sub WriteFile   # (filename , data)
{
    # save file in ascii mode
    ##my ($filename, $data, $binary) = @_;
    open (OUT, ">$_[0]") || die "Error: Can't create $_[0]\n";
    binmode OUT if ($_[2]);
    print OUT $_[1];
    close OUT;
}



sub ParsePRKList
{
    my ($data) = @_;
    my @nv = $data =~ m%<!--Key:(.*?)-->.*?<tr>(.*?)</tr>%gs;
    my ($i, $n, $v);
    for($i=0; $i < @nv; $i += 2) {
        $n = $nv[$i];
        $v = $nv[$i+1];     # contains a row
        $v =~ s%.*<td>(.*)</td>%$1%s;   # get last col
        $v =~ s/<.*?>//sg;      # remove font, etc
        $v =~ s/ //sg;
        $v =~ s/\n//sg;
        my $d = "$n [$v]";
        print "$d\n";
    }
}


sub ParseSummaryFile
{
    my ($data) = @_;
    
    my @nv = $data =~/<SOFTPKG NAME=\"(.*?)\" VERSION=\"(.*?)\">/g;
    my ($i, $n, $v);
    for($i=0; $i < @nv; $i += 2) {
        $n = $nv[$i];
        $v = $nv[$i+1];
        while($v =~ s/,0$//) { 1; }
        $v =~ s/,/./g;
        my $d = "$n [$v]";
        print "$d\n";
    }
}


sub Test
{
    my $data = ReadFile("e:/perl/02packages.details.txt");
    ParseCPANFile($data);
}




sub FetchCPANIndexFile
{
    my ($path) = @_;
    my $data;

    my $remotefile = "$path/modules/02packages.details.txt.gz";
    my $localfile = "$dpmdatadir/02packages.details.txt";
    mkpath($dpmdatadir, 0, 755) if (!-d $dpmdatadir);

    if (-e $localfile && -e "$localfile.gz" && is_old($localfile, "$localfile.gz")) {
        print "DBG: Removing outdated $localfile\n" if $debug;
        unlink $localfile;
    }

    if (-d $path) {
        # local CPAN copy
        if  (!($data = ReadFile($remotefile, 1))) {
            print "FetchCPANIndexFile: ERROR 1\n";
            return undef;
        }
        WriteFile("$localfile.gz", $data, 1);
    }

    if (!-e $localfile && !-e "$localfile.gz") {
        #print "#Fetching $remotefile\n";
        ReadURL($remotefile, "$localfile.gz") ||
            print "#Fetch failed\n";
    }

    if (!-e $localfile && -e "$localfile.gz") {
        #print "#Unpacking $localfile.gz\n";
        $data = "";
        my $buffer;
        my $gz = Compress::Zlib::gzopen("$localfile.gz", "rb");
        $data .= $buffer while $gz->gzread($buffer) > 0 ;
        $gz->gzclose() ;
        WriteFile($localfile, $data);
        unlink "$localfile.gz";
        return $data;
    }
    if (-e $localfile) {
        $data = ReadFile($localfile);
        return $data;
    }
    print "#FetchCPANIndexFile: ERROR 2\n";
    return undef;
}




sub ParseCPANFile
{
    my ($data) = @_;
    my ($f, $v);

    $data =~ s/.*?\n\n//s;  # chop off header
    my @lines = split("\n", $data);

    my %files = ();
    my ($line);    
    foreach $line (@lines) {
        $f = "";
        ($v, $f) = $line =~ m/[^\s]+\s+([^\s]+)\s+([^\s]+)/;
        my ($p, $x) = $f =~ m%(.*)/([^/]+)%;
        #$x =~ s/\.tar.gz|\.tgz//;
        #print "$x\n";
        $files{$x} = $f;
    }

    foreach $f (sort {uc($a) cmp uc($b)} keys %files) {
        print "$f\n";
        #print "authors/id/$files{$f}\n";
    }
}


sub is_old {
    # return true if file 1 is older than file 2,3,4,..    
    my $target = shift @_;
    my $targettime = (stat($target))[9];
    my @sources = @_;
    foreach my $file (@sources) {
        my $filetime = (stat($file))[9];
        if ($filetime > $targettime) {
            #print "$file is newer than $target\n";
        }
        return 1 if ($filetime > $targettime);
    }
    return 0;
}


sub usage
{
    print <<"EOT";
Usage:
dpm query
        List installed packages

dpm list [-location=path] [path]...
        List available packages at specified path

dpm install [-location=path] [-save_location=path] [path]PackageName[.ppd|.tar.gz]...
        Install specified packages.

dpm save [-location=path] -save_location=path [path]PackageName[.ppd|.tar.gz]...
        Save specified packages to a local repository

dpm remove package...
        Remove specified packages


If location is specified it is prefixed to each specified package.

Listing path can be one of the following:
URL to a web server directory
Local directory
Local directory containing .ppd files
Local directory containing subdirectories of locally made CPAN modules.

Installation path is one of the following:
Local or URL path to a PPD file or a tar file
  (the .ppd extension is not required)
Local CPAN module build directory containing a blib sub-directory

In order to build CPAN source modules you need MSVC installed.  You will also 
need to run vcvars32.bat to set required environment variables.

examples:
dpm install http://www.indigostar.com/packages/perl5_6/Alias
dpm install http://www.activestate.com/PPMPackages/5.6/Alias
dpm remove Alias
dpm install http://dada.perl.it/PPM/Win32-GUI
dpm install http://www.perl.com/CPAN-local/ANSIColor-1.01.tar.gz



EOT
}

__END__
:endofperl
