tor-browser-build/tools/prune-old-builds

#!/usr/bin/perl -w

# Copyright (c) 2019, The Tor Project, Inc.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are
# met:
#
#     * Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
#
#     * Redistributions in binary form must reproduce the above
# copyright notice, this list of conditions and the following disclaimer
# in the documentation and/or other materials provided with the
# distribution.
#
#     * Neither the names of the copyright owners nor the names of its
# contributors may be used to endorse or promote products derived from
# this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
# OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


# 'prune-old-builds' is a script to prune old builds.
#
#
# Usage:
#  $ ./prune-old-builds [options] <directory>
#
#
# Available options:
#
# --dry-run
#         Don't delete anything, but say what would be deleted.
#
# --prefix <prefix>
#         Prefix of the directories to be removed. Default is 'tbb-nightly.'.
#
# --separator <c>
#         Separator character to separate the year, month, day in the directory
#         names. Default is '.'.
#
# --days <n>
#         Number of days that we should keep. Default is 6.
#
# --weeks <n>
#         Number of monday builds that we should keep. Default is 3.
#
# --months <n>
#         Number of 1st day of the month builds that we should keep.
#         Default is 3.

use strict;
use Getopt::Long;
use DateTime;
use DateTime::Duration;
use File::Path qw(remove_tree);

my %options = (
    days   => 6,
    weeks  => 3,
    months => 3,
    prefix => 'tbb-nightly.',
    separator => '.',
);

sub keep_builds {
    my %res;

    my $day = DateTime::Duration->new(days => 1);
    my $week = DateTime::Duration->new(weeks => 1);
    my $month = DateTime::Duration->new(months => 1);

    my $n = $options{days};
    my $dt = DateTime->now;
    while ($n) {
        $res{ $options{prefix} . $dt->ymd($options{separator}) } = 1;
        $dt = $dt - $day;
        $n--;
    }

    my $w = $options{weeks};
    while ($dt->day_of_week != 1) {
        $dt = $dt - $day;
    }
    while ($w) {
        $res{ $options{prefix} . $dt->ymd($options{separator}) } = 1;
        $dt = $dt - $week;
        $w--;
    }

    my $m = $options{months};
    $dt = DateTime->now;
    while ($dt->day != 1) {
        $dt = $dt - $day;
    }
    while ($m) {
        $res{ $options{prefix} . $dt->ymd($options{separator}) } = 1;
        $dt = $dt - $month;
        $m--;
    }

    return \%res;
}

sub clean_directory {
    my ($directory) = @_;
    my $k = keep_builds;
    chdir $directory || die "Error entering $directory";
    foreach my $file (glob "$options{prefix}*") {
        next unless $file =~ m/^$options{prefix}\d{4}$options{separator}\d{2}$options{separator}\d{2}$/;
        next if $k->{$file};
        if ($options{'dry-run'}) {
            print "Would remove $file\n";
        } else {
            remove_tree($file);
        }
    }
}

my @opts = qw(days=i weeks=i months=i prefix=s dry-run!);
Getopt::Long::GetOptions(\%options, @opts);
die "Missing argument: directory to clean" unless @ARGV;
foreach my $dir (@ARGV) {
    clean_directory($dir);
}