* Implement HTTP redirection support in snapshot downloader (required for

automatic mirror usage for ftp.kde.org) * Fix usage of Net::FTP::size when destination file does not exist. * Use the KDE FTP mirror redirection system to download from a local mirror instead of ftp.kde.org. * Instead of using the rm -rf command to remove work files, implement the feature natively (using File::Find). This is both more portable and less pucker-inducing. * Fix bug introduced with last commit where tarballs that had no repository URL information after /home/kde was left with a stray newline, breaking the svn switch. * Get ready for 1.4 release to commemorate the first alpha of KDE 4. I would appreciate testing from kdesvn-build users who have time so I don't do a brown bag release. :) svn path=/trunk/KDE/kdesdk/scripts/kdesvn-build; revision=658958
19 years ago · 30b26d7fb6
parent 6c07273188
commit 30b26d7fb6
1 changed files with 132 additions and 29 deletions
--- a/161
+++ b/161
@ -268,7 +268,7 @@ use constant {
    ERROR   => 5,
 };

-my $versionNum = '1.3';
+my $versionNum = '1.4-rc1';

 # Some global variables
 # Remember kids, global variables are evil!  I only get to do this
@ -1016,10 +1016,13 @@ sub get_fullpath
 # First parameter: Hostname of the server (i.e. kdesvn-build.kde.org)
 # Second parameter: Path of the file on the host (i.e. /files/blah.tbz2)
 # Third parameter: Filename to save as (i.e. $ENV{HOME}/blah.tbz2)
+# Fourth parameter: Reference to hash used to record if a redirection occurred,
+#                   and how many redirections have already been attempted.
+#                   See download_file()
 # Return value is 0 for failure, non-zero for success.
 sub download_http_file
 {
-    my ($host, $path, $filename) = @_;
+    my ($host, $path, $filename, $info) = @_;

    return 0 unless has_Net_HTTP();
    my $conn = Net::HTTP->new (Host => $host);
@ -1040,6 +1043,25 @@ sub download_http_file

    my ($code, $msg, %h) = $conn->read_response_headers();

+    # Try to handle redirections.  We handle them all pretty much the same,
+    # i.e. if the Location response is present use that, otherwise error out.
+    while (int $code / 100 == 3)
+    {
+        $info->{'redir_count'}++;
+        $conn->close(); # Error or not, we're done with this connection.
+
+        if (not $h{'Location'})
+        {
+            error "Unable to download file r[$path], ambiguous redirection.";
+            return 0;
+        }
+
+        my $destination = $h{'Location'};
+        $destination =~ s/^Location:\s*//;
+        $info->{'redirection'} = $destination;
+        return 0;
+    }
+
    if (200 != $code)
    {
        error "Unable to download file r[$path]:\n\tr[b[$msg]";
@ -1120,7 +1142,8 @@ sub download_ftp_file
    $ftp->binary(); # Switch to binary mode.

    # Check if file exists.
-    if ($ftp->size($path) <= 0)
+    my $size = $ftp->size($path);
+    if (not $size or $size <= 0)
    {
        $ftp->quit();
        return 0;
@ -1156,28 +1179,51 @@ sub download_file
        return 1;
    }

-    my ($protocol, $host, $path) = ($url =~ m{^([^:]+)://([^/]+)(/.*)$});
+    my ($protocol, $host, $path);
+    my $info = { 'redir_count' => 0, 'redirection' => '' };

-    if (not defined $url or not defined $host or not defined $path)
+    while ($info->{'redir_count'} < 5)
    {
-        error "Trying to download file from invalid URL: r[$url]";
-        return 0;
-    }
+        ($protocol, $host, $path) = ($url =~ m{^([^:]+)://([^/]+)(/.*)$});
+        if (not defined $url or not defined $host or not defined $path)
+        {
+            error "Trying to download file from invalid URL: r[$url]";
+            return 0;
+        }

-    # Not sure if https works but no harm in letting it try.
-    if ($protocol =~ /^https?$/)
-    {
-        whisper "Downloading g[$path] from g[$url]";
-        return download_http_file($host, $path, $filename);
-    }
-    elsif ($protocol eq 'ftp')
-    {
-        whisper "Downloading g[$path] from g[$url]";
-        return download_ftp_file($host, $path, $filename);
+        $info->{'redirection'} = '';
+
+        # Not sure if https works but no harm in letting it try.
+        if ($protocol =~ /^https?$/)
+        {
+            whisper "Downloading g[$path] from g[$url]";
+            my $result = download_http_file($host, $path, $filename, $info);
+
+            if (not $result and $info->{'redirection'})
+            {
+                # Try again at new URL.
+                $url = $info->{'redirection'};
+                whisper "Redirecting to y[$url]";
+                next;
+            }
+            else
+            {
+                return $result;
+            }
+        }
+        elsif ($protocol eq 'ftp')
+        {
+            whisper "Downloading g[$path] from g[$url]";
+            return download_ftp_file($host, $path, $filename);
+        }
+        else
+        {
+            error "Trying to download file ($url), but";
+            error "\tthe r[$protocol] protocol is unsupported.";
+            return 0;
+        }
    }

-    error "Trying to download file ($url), but";
-    error "\tthe r[$protocol] protocol is unsupported.";
    return 0;
 }

@ -1206,7 +1252,8 @@ sub install_module_snapshot
    if ($branch eq 'trunk')
    {
        $filename = "$moduleName-svn.tar.bz2";
-        $url = "ftp://ftp.kde.org/pub/kde/unstable/snapshots/$filename";
+        #$url = "ftp://ftp.kde.org/pub/kde/unstable/snapshots/$filename";
+        $url = "http://download.kde.org/download.php?url=unstable/snapshots/$moduleName-svn.tar.bz2";
        $dirName = "$moduleName";

        if (download_module_snapshot($module, $filename, $url, $dirName))
@ -1301,7 +1348,7 @@ sub download_module_snapshot
        error "Unable to extract snapshot for r[$module]: $savedError";

        # Remove any created portions of the module tree.
-        safe_system("rm", "-rf", "$dirName");
+        safe_rmtree($dirName);

        return 0;
    }
@ -1314,8 +1361,8 @@ sub download_module_snapshot
        error "Unable to move directory for r[$module] into place: r[$!]";

        # Remove any created portions of the module tree.
-        safe_system("rm", "-rf", $dirName);
-        safe_system("rm", "-rf", $moduleName);
+        safe_rmtree($dirName);
+        safe_rmtree($moduleName);

        return 0;
    }
@ -1330,6 +1377,7 @@ sub download_module_snapshot
    my $curSvnHost = `svn info | grep ^URL`;
    $curSvnHost =~ s/^URL:\s*//;
    $curSvnHost =~ s/\/home\/kde.*$/\/home\/kde/; # Remove stuff after /home/kde
+    chomp $curSvnHost;

    info "\tFinalizing Subversion information for g[$module]";

@ -1347,7 +1395,7 @@ sub download_module_snapshot

            # Remove any created portions of the module tree.
            p_chdir("..");
-            safe_system("rm", "-rf", $moduleName);
+            safe_rmtree($moduleName);

            return 0;
        }
@ -1369,7 +1417,7 @@ sub download_module_snapshot

        # Remove any created portions of the module tree.
        p_chdir("..");
-        safe_system("rm", "-rf", $moduleName);
+        safe_rmtree($moduleName);

        return 0;
    }
@ -1984,6 +2032,60 @@ sub path_to_prog
    return undef;
 }

+# Subroutine to delete a directory and all files and subdirectories within.
+# Does nothing in pretend mode.  An analogue to "rm -rf" from Linux.
+# Requires File::Find module.
+#
+# First parameter: Path to delete
+# Returns boolean true on success, boolean false for failure.
+sub safe_rmtree
+{
+    my $path = shift;
+    my $delete_file_or_dir = sub {
+        # $_ is the filename/dirname
+        return if $_ eq '.' or $_ eq '..';
+        if (-f $_)
+        {
+            unlink ($_) or die "Unable to delete $File::Find::name!";
+        }
+        elsif (-d $_)
+        {
+            rmdir ($File::Find::name)  or die "Unable to remove directory $File::Find::name: $!";
+        }
+    };
+
+    if (pretending)
+    {
+        pretend "Would have recursively removed $path";
+        return 1;
+    }
+
+    # Error out because we probably have a logic error even though it would
+    # delete just fine.
+    if (not -d $path)
+    {
+        error "Cannot recursively remove $path, as it is not a directory.";
+        return 0;
+    }
+
+    eval {
+        $@ = '';
+        finddepth( # finddepth does a postorder traversal.
+        {
+            wanted => $delete_file_or_dir,
+            no_chdir => 1, # We'll end up deleting directories, so prevent this.
+        }, $path);
+    };
+
+    if ($@)
+    {
+        error "Unable to remove directory $path: $@";
+        return 0;
+    }
+
+    return 1;
+}
+
 # Subroutine to run the make command with the arguments given by the passed
 # list.  The first argument of the list given must be the module that we're
 # making.  The second argument is the "try number", used in creating the log
@ -4392,7 +4494,7 @@ sub clean_build_system
        }

        # Let users know we're done so they don't wonder why rm -rf is taking so
-        # long and oh yeah, why'd my HD so active?...
+        # long and oh yeah, why's my HD so active?...
        info "\tOld build system cleaned, starting new build system.";
    }
    # or create the directory
@ -5169,14 +5271,14 @@ sub handle_install
            # Remove srcdir
            my $srcdir = get_fullpath($module, 'source');
            note "\tRemoving b[r[$module source].";
-            system ('rm', '-rf', $srcdir);
+            safe_rmtree($srcdir);
        }

        if($remove_setting eq 'builddir' or $remove_setting eq 'all')
        {
            # Remove builddir
            note "\tRemoving b[r[$module build directory].";
-            system ('rm', '-rf', $builddir);
+            safe_rmtree($builddir);
        }
    }

@ -5531,6 +5633,7 @@ eval
    }

    eval { plugin_setup_default_modules(\@update_list, \@build_list, \%package_opts); };
+    $@ = ''; # Clear errors that result when not using Coverity plugin.

    @update_list = get_update_list();
    @build_list = get_build_list();