View | Details | Raw Unified | Return to bug 8991
Collapse All | Expand All

(-)a/misc/cronjobs/purge_orders.pl (-1 / +191 lines)
Line 0 Link Here
0
- 
1
#!/usr/bin/perl
2
3
# Copyright 2013 BibLibre
4
# This file is part of Koha.
5
#
6
# Koha is free software; you can redistribute it and/or modify it under the
7
# terms of the GNU General Public License as published by the Free Software
8
# Foundation; either version 2 of the License, or (at your option) any later
9
# version.
10
#
11
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
12
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
13
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
14
#
15
# You should have received a copy of the GNU General Public License along with
16
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
17
# Suite 330, Boston, MA  02111-1307 USA
18
19
use Modern::Perl;
20
21
use Pod::Usage;
22
use Getopt::Long;
23
24
use C4::Acquisition qw( DelBasket );
25
use C4::Context;
26
use Koha::DateUtils;
27
28
my ( $help, $verbose, $until, $confirm, $basketno );
29
GetOptions(
30
    'h'         => \$help,
31
    'v'         => \$verbose,
32
    'until:s'   => \$until,
33
    ''          => \$basketno,
34
    'c|confirm' => \$confirm,
35
);
36
37
if ( $help or not $until ) {
38
    usage();
39
    exit;
40
}
41
42
# Check if the date is well formatted
43
eval {
44
    $until = output_pref( dt_from_string( $until ), 'iso' )
45
        if not $until =~ /^\d{4}-\d{2}-\d{2}$/;
46
};
47
if ( $@ or not $until) {
48
    usage();
49
    say "The until parameter is not in a good format.";
50
    exit 1;
51
}
52
53
# If confirm is not set, we want to display the output
54
$verbose = 1 unless $confirm;
55
56
say "All orders received until $until will be deleted"
57
    if $verbose;
58
my $orders_to_delete = get_orders_to_delete( $until, $verbose );
59
say plural($orders_to_delete, "order") . " to delete"
60
    if $verbose;
61
62
# We have orders to delete
63
if ( @$orders_to_delete ) {
64
    if ( $verbose ) {
65
        # Display ordernumber and biblionumber for each one
66
        for my $order ( @$orders_to_delete ) {
67
            say "\t- ordernumber $order->{ordernumber} with biblionumber " . ( $order->{biblionumber} ? $order->{biblionumber} : " NULL " );
68
        }
69
    }
70
71
    my $deleted;
72
    if ( $confirm ) {
73
        # We really want to delete them!
74
        $deleted = delete_orders( $until, $confirm, $verbose );
75
76
        # Not all orders have been deleted, displaying an error message.
77
        if ( $deleted != scalar @$orders_to_delete ) {
78
            say "ERROR: " . plural ( $orders_to_delete, "order" ) . " deleted (" . $deleted . "expected)";
79
        } elsif ( $deleted ) {
80
            say "" . plural ( $deleted, "order" ) . " deleted"
81
                if $verbose;
82
        }
83
    }
84
    # At least 1 order has been deleted or we are in the dry-run mode
85
    # We want to delete empty closed baskets
86
    if ( $deleted or not $confirm ) {
87
        my $baskets_to_delete = get_baskets_to_delete();
88
        say "" . plural( $baskets_to_delete, "basket" ) . " to delete"
89
            if $verbose;
90
        for my $basket ( @$baskets_to_delete ) {
91
            say "\t- basket " . $basket->{basketno} . " (" . $basket->{basketname} . ")"
92
                if $verbose;
93
            C4::Acquisition::DelBasket( $basket->{basketno} )
94
                if $confirm;
95
        }
96
    }
97
}
98
99
# Returns orders received before a given date.
100
sub get_orders_to_delete {
101
    my ( $date ) = @_;
102
    return unless $date;
103
    my $dbh = C4::Context->dbh;
104
    my $query = q{
105
        SELECT ordernumber,biblionumber,basketno
106
        FROM aqorders
107
        WHERE datereceived <= ?
108
    };
109
    my $sth = $dbh->prepare( $query );
110
    $sth->execute( $date );
111
    return $sth->fetchall_arrayref( {} );
112
}
113
114
# Delete orders received before a given date.
115
# Returns the number of deletions.
116
sub delete_orders {
117
    my ( $date ) = @_;
118
119
    my $dbh = C4::Context->dbh;
120
    my $query = q{
121
        DELETE FROM aqorders
122
        WHERE datereceived <= ?
123
    };
124
    my $sth = $dbh->prepare( $query );
125
    my $deleted = $sth->execute( $date );
126
    $deleted = 0 if $deleted eq '0E0';
127
128
    return $deleted;
129
}
130
131
# Returns closed baskets without orders.
132
sub get_baskets_to_delete {
133
    my $dbh = C4::Context->dbh;
134
    my $query = q{
135
        SELECT DISTINCT(b.basketno), b.basketname
136
        FROM aqbasket b
137
        LEFT JOIN aqorders o ON b.basketno=o.basketno
138
        WHERE o.basketno IS NULL
139
        AND b.closedate IS NOT NULL
140
    };
141
    my $sth = $dbh->prepare( $query );
142
    $sth->execute();
143
    return $sth->fetchall_arrayref( {} );
144
}
145
146
sub plural {
147
    my ( $value, $string ) = @_;
148
    my $n = ref $value ? scalar @$value : $value;
149
    return $n . " " . $string . 's' if ( $n > 1 );
150
    return "1 $string" if $n;
151
    return "0 $string";
152
}
153
154
sub usage {
155
    pod2usage( -verbose => 2 );
156
    exit;
157
}
158
159
=head1 NAME
160
161
purge_orders.pl - This script delete old orders
162
163
=head1 USAGE
164
165
purge_orders.pl [-h -until=<untildate> -v]
166
167
example: perl purge_orders.pl -until `date -d '-12 month' "+%Y-%m-%d"`
168
169
=head1 PARAMETERS
170
171
=over
172
173
=item B<-h>
174
175
Print a brief help message
176
177
=item B<-until>
178
179
Delete orders before this date (format YYYY-MM-DD or like the "metric" syspref)
180
181
=item B<-v>
182
183
Verbose mode.
184
185
=item B<-c|--confirm>
186
187
Without this flag set, this script will do nothing.
188
189
=back
190
191
=cut

Return to bug 8991