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

(-)a/C4/Auth.pm (-25 / +5 lines)
Lines 32-37 use C4::Templates; # to get the template Link Here
32
use C4::Languages;
32
use C4::Languages;
33
use C4::Search::History;
33
use C4::Search::History;
34
use Koha;
34
use Koha;
35
use Koha::Logger;
35
use Koha::Caches;
36
use Koha::Caches;
36
use Koha::AuthUtils qw(get_script_name hash_password);
37
use Koha::AuthUtils qw(get_script_name hash_password);
37
use Koha::Checkouts;
38
use Koha::Checkouts;
Lines 50-56 use Net::CIDR; Link Here
50
use C4::Log qw/logaction/;
51
use C4::Log qw/logaction/;
51
52
52
# use utf8;
53
# use utf8;
53
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug $ldap $cas $caslogout);
54
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $ldap $cas $caslogout);
54
55
55
BEGIN {
56
BEGIN {
56
    sub psgi_env { any { /^psgi\./ } keys %ENV }
57
    sub psgi_env { any { /^psgi\./ } keys %ENV }
Lines 62-68 BEGIN { Link Here
62
63
63
    C4::Context->set_remote_address;
64
    C4::Context->set_remote_address;
64
65
65
    $debug     = $ENV{DEBUG};
66
    @ISA       = qw(Exporter);
66
    @ISA       = qw(Exporter);
67
    @EXPORT    = qw(&checkauth &get_template_and_user &haspermission &get_user_subpermissions);
67
    @EXPORT    = qw(&checkauth &get_template_and_user &haspermission &get_user_subpermissions);
68
    @EXPORT_OK = qw(&check_api_auth &get_session &check_cookie_auth &checkpw &checkpw_internal &checkpw_hash
68
    @EXPORT_OK = qw(&check_api_auth &get_session &check_cookie_auth &checkpw &checkpw_internal &checkpw_hash
Lines 763-769 sub _version_check { Link Here
763
763
764
    # remove the 3 last . to have a Perl number
764
    # remove the 3 last . to have a Perl number
765
    $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
765
    $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
766
    $debug and print STDERR "kohaversion : $kohaversion\n";
766
    Koha::Logger->get->debug("kohaversion : $kohaversion");
767
    if ( $version < $kohaversion ) {
767
    if ( $version < $kohaversion ) {
768
        my $warning = "Database update needed, redirecting to %s. Database is $version and Koha is $kohaversion";
768
        my $warning = "Database update needed, redirecting to %s. Database is $version and Koha is $kohaversion";
769
        if ( $type ne 'opac' ) {
769
        if ( $type ne 'opac' ) {
Lines 806-812 sub _timeout_syspref { Link Here
806
806
807
sub checkauth {
807
sub checkauth {
808
    my $query = shift;
808
    my $query = shift;
809
    $debug and warn "Checking Auth";
810
809
811
    # Get shibboleth login attribute
810
    # Get shibboleth login attribute
812
    my $shib = C4::Context->config('useshibboleth') && shib_ok();
811
    my $shib = C4::Context->config('useshibboleth') && shib_ok();
Lines 893-899 sub checkauth { Link Here
893
                $session->param('desk_id'),      $session->param('desk_name'),
892
                $session->param('desk_id'),      $session->param('desk_name'),
894
                $session->param('register_id'),  $session->param('register_name')
893
                $session->param('register_id'),  $session->param('register_name')
895
            );
894
            );
896
            $debug and printf STDERR "AUTH_SESSION: (%s)\t%s %s - %s\n", map { $session->param($_) } qw(cardnumber firstname surname branch);
895
            Koha::Logger->get->debug(sprintf "AUTH_SESSION: (%s)\t%s %s - %s", map { $session->param($_) } qw(cardnumber firstname surname branch));
897
            $ip          = $session->param('ip');
896
            $ip          = $session->param('ip');
898
            $lasttime    = $session->param('lasttime');
897
            $lasttime    = $session->param('lasttime');
899
            $userid      = $s_userid;
898
            $userid      = $s_userid;
Lines 906-912 sub checkauth { Link Here
906
905
907
            #if a user enters an id ne to the id in the current session, we need to log them in...
906
            #if a user enters an id ne to the id in the current session, we need to log them in...
908
            #first we need to clear the anonymous session...
907
            #first we need to clear the anonymous session...
909
            $debug and warn "query id = $q_userid but session id = $s_userid";
910
            $anon_search_history = $session->param('search_history');
908
            $anon_search_history = $session->param('search_history');
911
            $session->delete();
909
            $session->delete();
912
            $session->flush;
910
            $session->flush;
Lines 1143-1167 sub checkauth { Link Here
1143
                    my $sth = $dbh->prepare("$select where userid=?");
1141
                    my $sth = $dbh->prepare("$select where userid=?");
1144
                    $sth->execute($userid);
1142
                    $sth->execute($userid);
1145
                    unless ( $sth->rows ) {
1143
                    unless ( $sth->rows ) {
1146
                        $debug and print STDERR "AUTH_1: no rows for userid='$userid'\n";
1147
                        $sth = $dbh->prepare("$select where cardnumber=?");
1144
                        $sth = $dbh->prepare("$select where cardnumber=?");
1148
                        $sth->execute($cardnumber);
1145
                        $sth->execute($cardnumber);
1149
1146
1150
                        unless ( $sth->rows ) {
1147
                        unless ( $sth->rows ) {
1151
                            $debug and print STDERR "AUTH_2a: no rows for cardnumber='$cardnumber'\n";
1152
                            $sth->execute($userid);
1148
                            $sth->execute($userid);
1153
                            unless ( $sth->rows ) {
1154
                                $debug and print STDERR "AUTH_2b: no rows for userid='$userid' AS cardnumber\n";
1155
                            }
1156
                        }
1149
                        }
1157
                    }
1150
                    }
1158
                    if ( $sth->rows ) {
1151
                    if ( $sth->rows ) {
1159
                        ( $borrowernumber, $firstname, $surname, $userflags,
1152
                        ( $borrowernumber, $firstname, $surname, $userflags,
1160
                            $branchcode, $branchname, $emailaddress ) = $sth->fetchrow;
1153
                            $branchcode, $branchname, $emailaddress ) = $sth->fetchrow;
1161
                        $debug and print STDERR "AUTH_3 results: " .
1162
                          "$cardnumber,$borrowernumber,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress\n";
1163
                    } else {
1164
                        print STDERR "AUTH_3: no results for userid='$userid', cardnumber='$cardnumber'.\n";
1165
                    }
1154
                    }
1166
1155
1167
                    # launch a sequence to check if we have a ip for the branch, i
1156
                    # launch a sequence to check if we have a ip for the branch, i
Lines 1236-1242 sub checkauth { Link Here
1236
                    $session->param( 'shibboleth',   $shibSuccess );
1225
                    $session->param( 'shibboleth',   $shibSuccess );
1237
                    $session->param( 'register_id',  $register_id );
1226
                    $session->param( 'register_id',  $register_id );
1238
                    $session->param( 'register_name',  $register_name );
1227
                    $session->param( 'register_name',  $register_name );
1239
                    $debug and printf STDERR "AUTH_4: (%s)\t%s %s - %s\n", map { $session->param($_) } qw(cardnumber firstname surname branch);
1240
                }
1228
                }
1241
                $session->param('cas_ticket', $cas_ticket) if $cas_ticket;
1229
                $session->param('cas_ticket', $cas_ticket) if $cas_ticket;
1242
                C4::Context->set_userenv(
1230
                C4::Context->set_userenv(
Lines 1253-1259 sub checkauth { Link Here
1253
            # $return: 0 = invalid user
1241
            # $return: 0 = invalid user
1254
            # reset to anonymous session
1242
            # reset to anonymous session
1255
            else {
1243
            else {
1256
                $debug and warn "Login failed, resetting anonymous session...";
1257
                if ($userid) {
1244
                if ($userid) {
1258
                    $info{'invalid_username_or_password'} = 1;
1245
                    $info{'invalid_username_or_password'} = 1;
1259
                    C4::Context->_unset_userenv($sessionID);
1246
                    C4::Context->_unset_userenv($sessionID);
Lines 1266-1274 sub checkauth { Link Here
1266
        }    # END if ( $q_userid
1253
        }    # END if ( $q_userid
1267
        elsif ( $type eq "opac" ) {
1254
        elsif ( $type eq "opac" ) {
1268
1255
1269
            # if we are here this is an anonymous session; add public lists to it and a few other items...
1270
            # anonymous sessions are created only for the OPAC
1256
            # anonymous sessions are created only for the OPAC
1271
            $debug and warn "Initiating an anonymous session...";
1272
1257
1273
            # setting a couple of other session vars...
1258
            # setting a couple of other session vars...
1274
            $session->param( 'ip',          $session->remote_addr() );
1259
            $session->param( 'ip',          $session->remote_addr() );
Lines 1589-1595 sub check_api_auth { Link Here
1589
        # Proxy CAS auth
1574
        # Proxy CAS auth
1590
        if ( $cas && $query->param('PT') ) {
1575
        if ( $cas && $query->param('PT') ) {
1591
            my $retuserid;
1576
            my $retuserid;
1592
            $debug and print STDERR "## check_api_auth - checking CAS\n";
1593
1577
1594
            # In case of a CAS authentication, we use the ticket instead of the password
1578
            # In case of a CAS authentication, we use the ticket instead of the password
1595
            my $PT = $query->param('PT');
1579
            my $PT = $query->param('PT');
Lines 1905-1911 sub checkpw { Link Here
1905
    if ( $patron and $patron->account_locked ) {
1889
    if ( $patron and $patron->account_locked ) {
1906
        # Nothing to check, account is locked
1890
        # Nothing to check, account is locked
1907
    } elsif ($ldap && defined($password)) {
1891
    } elsif ($ldap && defined($password)) {
1908
        $debug and print STDERR "## checkpw - checking LDAP\n";
1909
        my ( $retval, $retcard, $retuserid ) = checkpw_ldap(@_);    # EXTERNAL AUTH
1892
        my ( $retval, $retcard, $retuserid ) = checkpw_ldap(@_);    # EXTERNAL AUTH
1910
        if ( $retval == 1 ) {
1893
        if ( $retval == 1 ) {
1911
            @return = ( $retval, $retcard, $retuserid );
1894
            @return = ( $retval, $retcard, $retuserid );
Lines 1914-1920 sub checkpw { Link Here
1914
        $check_internal_as_fallback = 1 if $retval == 0;
1897
        $check_internal_as_fallback = 1 if $retval == 0;
1915
1898
1916
    } elsif ( $cas && $query && $query->param('ticket') ) {
1899
    } elsif ( $cas && $query && $query->param('ticket') ) {
1917
        $debug and print STDERR "## checkpw - checking CAS\n";
1918
1900
1919
        # In case of a CAS authentication, we use the ticket instead of the password
1901
        # In case of a CAS authentication, we use the ticket instead of the password
1920
        my $ticket = $query->param('ticket');
1902
        my $ticket = $query->param('ticket');
Lines 1933-1940 sub checkpw { Link Here
1933
    # time around.
1915
    # time around.
1934
    elsif ( $shib && $shib_login && !$password ) {
1916
    elsif ( $shib && $shib_login && !$password ) {
1935
1917
1936
        $debug and print STDERR "## checkpw - checking Shibboleth\n";
1937
1938
        # In case of a Shibboleth authentication, we expect a shibboleth user attribute
1918
        # In case of a Shibboleth authentication, we expect a shibboleth user attribute
1939
        # (defined under shibboleth mapping in koha-conf.xml) to contain the login of the
1919
        # (defined under shibboleth mapping in koha-conf.xml) to contain the login of the
1940
        # shibboleth-authenticated user
1920
        # shibboleth-authenticated user
Lines 2240-2246 sub in_iprange { Link Here
2240
    if (scalar @allowedipranges > 0) {
2220
    if (scalar @allowedipranges > 0) {
2241
        my @rangelist;
2221
        my @rangelist;
2242
        eval { @rangelist = Net::CIDR::range2cidr(@allowedipranges); }; return 0 if $@;
2222
        eval { @rangelist = Net::CIDR::range2cidr(@allowedipranges); }; return 0 if $@;
2243
        eval { $result = Net::CIDR::cidrlookup($ENV{'REMOTE_ADDR'}, @rangelist) } || ( $ENV{DEBUG} && warn 'cidrlookup failed for ' . join(' ',@rangelist) );
2223
        eval { $result = Net::CIDR::cidrlookup($ENV{'REMOTE_ADDR'}, @rangelist) } || Koha::Logger->get->warn('cidrlookup failed for ' . join(' ',@rangelist) );
2244
     }
2224
     }
2245
     return $result ? 1 : 0;
2225
     return $result ? 1 : 0;
2246
}
2226
}
(-)a/C4/Auth_with_cas.pm (-17 / +10 lines)
Lines 27-38 use CGI qw ( -utf8 ); Link Here
27
use FindBin;
27
use FindBin;
28
use YAML::XS;
28
use YAML::XS;
29
29
30
use Koha::Logger;
30
31
31
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug);
32
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
32
33
33
BEGIN {
34
BEGIN {
34
    require Exporter;
35
    require Exporter;
35
    $debug = $ENV{DEBUG};
36
    @ISA   = qw(Exporter);
36
    @ISA   = qw(Exporter);
37
    @EXPORT = qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url logout_if_required);
37
    @EXPORT = qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url logout_if_required);
38
}
38
}
Lines 99-112 sub login_cas_url { Link Here
99
# Checks for password correctness
99
# Checks for password correctness
100
# In our case : is there a ticket, is it valid and does it match one of our users ?
100
# In our case : is there a ticket, is it valid and does it match one of our users ?
101
sub checkpw_cas {
101
sub checkpw_cas {
102
    $debug and warn "checkpw_cas";
103
    my ($dbh, $ticket, $query, $type) = @_;
102
    my ($dbh, $ticket, $query, $type) = @_;
104
    my $retnumber;
103
    my $retnumber;
105
    my ( $cas, $uri ) = _get_cas_and_service($query, undef, $type);
104
    my ( $cas, $uri ) = _get_cas_and_service($query, undef, $type);
106
105
107
    # If we got a ticket
106
    # If we got a ticket
108
    if ($ticket) {
107
    if ($ticket) {
109
        $debug and warn "Got ticket : $ticket";
110
108
111
        # We try to validate it
109
        # We try to validate it
112
        my $val = $cas->service_validate($uri, $ticket );
110
        my $val = $cas->service_validate($uri, $ticket );
Lines 115-121 sub checkpw_cas { Link Here
115
        if ( $val->is_success() ) {
113
        if ( $val->is_success() ) {
116
114
117
            my $userid = $val->user();
115
            my $userid = $val->user();
118
            $debug and warn "User CAS authenticated as: $userid";
119
116
120
            # we should store the CAS ticekt too, we need this for single logout https://apereo.github.io/cas/4.2.x/protocol/CAS-Protocol-Specification.html#233-single-logout
117
            # we should store the CAS ticekt too, we need this for single logout https://apereo.github.io/cas/4.2.x/protocol/CAS-Protocol-Specification.html#233-single-logout
121
118
Lines 134-146 sub checkpw_cas { Link Here
134
            }
131
            }
135
132
136
            # If we reach this point, then the user is a valid CAS user, but not a Koha user
133
            # If we reach this point, then the user is a valid CAS user, but not a Koha user
137
            $debug and warn "User $userid is not a valid Koha user";
134
            Koha::Logger->get->info("User $userid is not a valid Koha user");
138
135
139
        } else {
136
        } else {
140
            $debug and warn "Problem when validating ticket : $ticket";
137
            my $logger = Koha::Logger->get;
141
            $debug and warn "Authen::CAS::Client::Response::Error: " . $val->error() if $val->is_error();
138
            $logger->debug("Problem when validating ticket : $ticket");
142
            $debug and warn "Authen::CAS::Client::Response::Failure: " . $val->message() if $val->is_failure();
139
            $logger->debug("Authen::CAS::Client::Response::Error: " . $val->error()) if $val->is_error();
143
            $debug and warn Data::Dumper::Dumper($@) if $val->is_error() or $val->is_failure();
140
            $logger->debug("Authen::CAS::Client::Response::Failure: " . $val->message()) if $val->is_failure();
141
            $logger->debug(Data::Dumper::Dumper($@)) if $val->is_error() or $val->is_failure();
144
            return 0;
142
            return 0;
145
        }
143
        }
146
    }
144
    }
Lines 149-155 sub checkpw_cas { Link Here
149
147
150
# Proxy CAS auth
148
# Proxy CAS auth
151
sub check_api_auth_cas {
149
sub check_api_auth_cas {
152
    $debug and warn "check_api_auth_cas";
153
    my ($dbh, $PT, $query, $type) = @_;
150
    my ($dbh, $PT, $query, $type) = @_;
154
    my $retnumber;
151
    my $retnumber;
155
    my ( $cas, $uri ) = _get_cas_and_service($query, undef, $type);
152
    my ( $cas, $uri ) = _get_cas_and_service($query, undef, $type);
Lines 162-171 sub check_api_auth_cas { Link Here
162
        if ( $r->is_success ) {
159
        if ( $r->is_success ) {
163
160
164
            # We've got a username !
161
            # We've got a username !
165
            $debug and warn "User authenticated as: ", $r->user, "\n";
166
            $debug and warn "Proxied through:\n";
167
            $debug and warn "  $_\n" for $r->proxies;
168
169
            my $userid = $r->user;
162
            my $userid = $r->user;
170
163
171
            # we should store the CAS ticket too, we need this for single logout https://apereo.github.io/cas/4.2.x/protocol/CAS-Protocol-Specification.html#233-single-logout
164
            # we should store the CAS ticket too, we need this for single logout https://apereo.github.io/cas/4.2.x/protocol/CAS-Protocol-Specification.html#233-single-logout
Lines 186-195 sub check_api_auth_cas { Link Here
186
            }
179
            }
187
180
188
            # If we reach this point, then the user is a valid CAS user, but not a Koha user
181
            # If we reach this point, then the user is a valid CAS user, but not a Koha user
189
            $debug and warn "User $userid is not a valid Koha user";
182
            Koha::Logger->get->info("User $userid is not a valid Koha user");
190
183
191
        } else {
184
        } else {
192
            $debug and warn "Proxy Ticket authentication failed";
185
            Koha::Logger->get->debug("Proxy Ticket authentication failed");
193
            return 0;
186
            return 0;
194
        }
187
        }
195
    }
188
    }
(-)a/C4/Auth_with_ldap.pm (-24 / +17 lines)
Lines 29-35 use List::MoreUtils qw( any ); Link Here
29
use Net::LDAP;
29
use Net::LDAP;
30
use Net::LDAP::Filter;
30
use Net::LDAP::Filter;
31
31
32
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug);
32
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
33
33
34
BEGIN {
34
BEGIN {
35
	require Exporter;
35
	require Exporter;
Lines 60-68 $ldapname = $ldap->{user} ; Link Here
60
$ldappassword = $ldap->{pass}		;
60
$ldappassword = $ldap->{pass}		;
61
our %mapping  = %{$ldap->{mapping}}; # FIXME dpavlin -- don't die because of || (); from 6eaf8511c70eb82d797c941ef528f4310a15e9f9
61
our %mapping  = %{$ldap->{mapping}}; # FIXME dpavlin -- don't die because of || (); from 6eaf8511c70eb82d797c941ef528f4310a15e9f9
62
my @mapkeys = keys %mapping;
62
my @mapkeys = keys %mapping;
63
$debug and print STDERR "Got ", scalar(@mapkeys), " ldap mapkeys (  total  ): ", join ' ', @mapkeys, "\n";
63
#warn "Got ", scalar(@mapkeys), " ldap mapkeys (  total  ): ", join ' ', @mapkeys, "\n";
64
@mapkeys = grep {defined $mapping{$_}->{is}} @mapkeys;
64
@mapkeys = grep {defined $mapping{$_}->{is}} @mapkeys;
65
$debug and print STDERR "Got ", scalar(@mapkeys), " ldap mapkeys (populated): ", join ' ', @mapkeys, "\n";
65
#warn "Got ", scalar(@mapkeys), " ldap mapkeys (populated): ", join ' ', @mapkeys, "\n";
66
66
67
my %categorycode_conversions;
67
my %categorycode_conversions;
68
my $default_categorycode;
68
my $default_categorycode;
Lines 119-125 sub checkpw_ldap { Link Here
119
        return 0;
119
        return 0;
120
    }
120
    }
121
121
122
	#$debug and $db->debug(5);
123
    my $userldapentry;
122
    my $userldapentry;
124
123
125
    # first, LDAP authentication
124
    # first, LDAP authentication
Lines 208-214 sub checkpw_ldap { Link Here
208
    if (( $borrowernumber and $config{update}   ) or
207
    if (( $borrowernumber and $config{update}   ) or
209
        (!$borrowernumber and $config{replicate})   ) {
208
        (!$borrowernumber and $config{replicate})   ) {
210
        %borrower = ldap_entry_2_hash($userldapentry,$userid);
209
        %borrower = ldap_entry_2_hash($userldapentry,$userid);
211
        $debug and print STDERR "checkpw_ldap received \%borrower w/ " . keys(%borrower), " keys: ", join(' ', keys %borrower), "\n";
210
        #warn "checkpw_ldap received \%borrower w/ " . keys(%borrower), " keys: ", join(' ', keys %borrower), "\n";
212
    }
211
    }
213
212
214
    if ($borrowernumber) {
213
    if ($borrowernumber) {
Lines 265-285 sub ldap_entry_2_hash { Link Here
265
	my %borrower = ( cardnumber => shift );
264
	my %borrower = ( cardnumber => shift );
266
	my %memberhash;
265
	my %memberhash;
267
	$userldapentry->exists('uid');	# This is bad, but required!  By side-effect, this initializes the attrs hash. 
266
	$userldapentry->exists('uid');	# This is bad, but required!  By side-effect, this initializes the attrs hash. 
268
	if ($debug) {
267
    #foreach (keys %$userldapentry) {
269
		foreach (keys %$userldapentry) {
268
    #    print STDERR "\n\nLDAP key: $_\t", sprintf('(%s)', ref $userldapentry->{$_}), "\n";
270
			print STDERR "\n\nLDAP key: $_\t", sprintf('(%s)', ref $userldapentry->{$_}), "\n";
269
    #}
271
		}
272
	}
273
	my $x = $userldapentry->{attrs} or return;
270
	my $x = $userldapentry->{attrs} or return;
274
	foreach (keys %$x) {
271
	foreach (keys %$x) {
275
		$memberhash{$_} = join ' ', @{$x->{$_}};	
272
		$memberhash{$_} = join ' ', @{$x->{$_}};	
276
		$debug and print STDERR sprintf("building \$memberhash{%s} = ", $_, join(' ', @{$x->{$_}})), "\n";
273
        #warn sprintf("building \$memberhash{%s} = ", $_, join(' ', @{$x->{$_}})), "\n";
277
	}
274
	}
278
	$debug and print STDERR "Finsihed \%memberhash has ", scalar(keys %memberhash), " keys\n",
275
    #warn "Finished \%memberhash has ", scalar(keys %memberhash), " keys\n", "Referencing \%mapping with ", scalar(keys %mapping), " keys\n";
279
					"Referencing \%mapping with ", scalar(keys %mapping), " keys\n";
280
	foreach my $key (keys %mapping) {
276
	foreach my $key (keys %mapping) {
281
		my  $data = $memberhash{ lc($mapping{$key}->{is}) }; # Net::LDAP returns all names in lowercase
277
		my  $data = $memberhash{ lc($mapping{$key}->{is}) }; # Net::LDAP returns all names in lowercase
282
		$debug and printf STDERR "mapping %20s ==> %-20s (%s)\n", $key, $mapping{$key}->{is}, $data;
278
        #warn "mapping %20s ==> %-20s (%s)\n", $key, $mapping{$key}->{is}, $data;
283
		unless (defined $data) { 
279
		unless (defined $data) { 
284
            $data = $mapping{$key}->{content} || undef;
280
            $data = $mapping{$key}->{content} || undef;
285
		}
281
		}
Lines 304-310 sub ldap_entry_2_hash { Link Here
304
	$sth->execute( uc($borrower{'categorycode'}) );
300
	$sth->execute( uc($borrower{'categorycode'}) );
305
	unless ( my $row = $sth->fetchrow_hashref ) {
301
	unless ( my $row = $sth->fetchrow_hashref ) {
306
		my $default = $mapping{'categorycode'}->{content};
302
		my $default = $mapping{'categorycode'}->{content};
307
		$debug && warn "Can't find ", $borrower{'categorycode'}, " default to: $default for ", $borrower{userid};
303
        #warn "Can't find ", $borrower{'categorycode'}, " default to: $default for ", $borrower{userid};
308
		$borrower{'categorycode'} = $default
304
		$borrower{'categorycode'} = $default
309
	}
305
	}
310
306
Lines 318-329 sub exists_local { Link Here
318
314
319
	my $sth = $dbh->prepare("$select WHERE userid=?");	# was cardnumber=?
315
	my $sth = $dbh->prepare("$select WHERE userid=?");	# was cardnumber=?
320
	$sth->execute($arg);
316
	$sth->execute($arg);
321
	$debug and printf STDERR "Userid '$arg' exists_local? %s\n", $sth->rows;
317
    #warn "Userid '$arg' exists_local? %s\n", $sth->rows;
322
	($sth->rows == 1) and return $sth->fetchrow;
318
	($sth->rows == 1) and return $sth->fetchrow;
323
319
324
	$sth = $dbh->prepare("$select WHERE cardnumber=?");
320
	$sth = $dbh->prepare("$select WHERE cardnumber=?");
325
	$sth->execute($arg);
321
	$sth->execute($arg);
326
	$debug and printf STDERR "Cardnumber '$arg' exists_local? %s\n", $sth->rows;
322
    #warn "Cardnumber '$arg' exists_local? %s\n", $sth->rows;
327
	($sth->rows == 1) and return $sth->fetchrow;
323
	($sth->rows == 1) and return $sth->fetchrow;
328
	return 0;
324
	return 0;
329
}
325
}
Lines 358-364 sub _do_changepassword { Link Here
358
    }
354
    }
359
355
360
    my $digest = hash_password($password);
356
    my $digest = hash_password($password);
361
    $debug and print STDERR "changing local password for borrowernumber=$borrowerid to '$digest'\n";
357
    #warn "changing local password for borrowernumber=$borrowerid to '$digest'\n";
362
    Koha::Patrons->find($borrowerid)->set_password({ password => $password, skip_validation => 1 });
358
    Koha::Patrons->find($borrowerid)->set_password({ password => $password, skip_validation => 1 });
363
359
364
    my ($ok, $cardnum) = checkpw_internal(C4::Context->dbh, $userid, $password);
360
    my ($ok, $cardnum) = checkpw_internal(C4::Context->dbh, $userid, $password);
Lines 382-388 sub update_local { Link Here
382
        while ( my $attribute_type = $attribute_types->next ) {
378
        while ( my $attribute_type = $attribute_types->next ) {
383
           my $code = $attribute_type->code;
379
           my $code = $attribute_type->code;
384
           @keys = grep { $_ ne $code } @keys;
380
           @keys = grep { $_ ne $code } @keys;
385
           $debug and printf STDERR "ignoring extended patron attribute '%s' in update_local()\n", $code;
381
           #warn "ignoring extended patron attribute '%s' in update_local()\n", $code;
386
        }
382
        }
387
    }
383
    }
388
384
Lines 391-401 sub update_local { Link Here
391
        join(',', map {"$_=?"} @keys) .
387
        join(',', map {"$_=?"} @keys) .
392
        "\nWHERE   borrowernumber=? ";
388
        "\nWHERE   borrowernumber=? ";
393
    my $sth = $dbh->prepare($query);
389
    my $sth = $dbh->prepare($query);
394
    if ($debug) {
390
    #warn $query, "\n", join "\n", map {"$_ = '" . $borrower->{$_} . "'"} @keys;
395
        print STDERR $query, "\n",
391
    #warn "\nuserid = $userid\n";
396
            join "\n", map {"$_ = '" . $borrower->{$_} . "'"} @keys;
397
        print STDERR "\nuserid = $userid\n";
398
    }
399
    $sth->execute(
392
    $sth->execute(
400
        ((map {$borrower->{$_}} @keys), $borrowerid)
393
        ((map {$borrower->{$_}} @keys), $borrowerid)
401
    );
394
    );
(-)a/C4/Auth_with_shibboleth.pm (-30 / +17 lines)
Lines 28-38 use Carp; Link Here
28
use CGI;
28
use CGI;
29
use List::MoreUtils qw(any);
29
use List::MoreUtils qw(any);
30
30
31
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug);
31
use Koha::Logger;
32
33
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
32
34
33
BEGIN {
35
BEGIN {
34
    require Exporter;
36
    require Exporter;
35
    $debug   = $ENV{DEBUG};
36
    @ISA     = qw(Exporter);
37
    @ISA     = qw(Exporter);
37
    @EXPORT =
38
    @EXPORT =
38
      qw(shib_ok logout_shib login_shib_url checkpw_shib get_login_shib);
39
      qw(shib_ok logout_shib login_shib_url checkpw_shib get_login_shib);
Lines 83-92 sub get_login_shib { Link Here
83
    my $matchAttribute = $config->{mapping}->{ $config->{matchpoint} }->{is};
84
    my $matchAttribute = $config->{mapping}->{ $config->{matchpoint} }->{is};
84
85
85
    if ( any { /(^psgi\.|^plack\.)/i } keys %ENV ) {
86
    if ( any { /(^psgi\.|^plack\.)/i } keys %ENV ) {
86
      $debug and warn $matchAttribute . " value: " . $ENV{"HTTP_".uc($matchAttribute)};
87
      return $ENV{"HTTP_".uc($matchAttribute)} || '';
87
      return $ENV{"HTTP_".uc($matchAttribute)} || '';
88
    } else {
88
    } else {
89
      $debug and warn $matchAttribute . " value: " . $ENV{$matchAttribute};
90
      return $ENV{$matchAttribute} || '';
89
      return $ENV{$matchAttribute} || '';
91
    }
90
    }
92
}
91
}
Lines 94-111 sub get_login_shib { Link Here
94
# Checks for password correctness
93
# Checks for password correctness
95
# In our case : does the given attribute match one of our users ?
94
# In our case : does the given attribute match one of our users ?
96
sub checkpw_shib {
95
sub checkpw_shib {
97
    $debug and warn "checkpw_shib";
98
96
99
    my ( $match ) = @_;
97
    my ( $match ) = @_;
100
    my $config = _get_shib_config();
98
    my $config = _get_shib_config();
101
    $debug and warn "User Shibboleth-authenticated as: $match";
102
99
103
    # Does the given shibboleth attribute value ($match) match a valid koha user ?
100
    # Does the given shibboleth attribute value ($match) match a valid koha user ?
104
    my $borrowers = Koha::Patrons->search( { $config->{matchpoint} => $match } );
101
    my $borrowers = Koha::Patrons->search( { $config->{matchpoint} => $match } );
105
    if ( $borrowers->count > 1 ){
102
    if ( $borrowers->count > 1 ){
106
        # If we have more than 1 borrower the matchpoint is not unique
103
        # If we have more than 1 borrower the matchpoint is not unique
107
        # we cannot know which patron is the correct one, so we should fail
104
        # we cannot know which patron is the correct one, so we should fail
108
         $debug and warn "There are several users with $config->{matchpoint} of $match, matchpoints must be unique";
105
        Koha::Logger->get->warn("There are several users with $config->{matchpoint} of $match, matchpoints must be unique");
109
        return 0;
106
        return 0;
110
    }
107
    }
111
    my $borrower = $borrowers->next;
108
    my $borrower = $borrowers->next;
Lines 120-126 sub checkpw_shib { Link Here
120
        return _autocreate( $config, $match );
117
        return _autocreate( $config, $match );
121
    } else {
118
    } else {
122
        # If we reach this point, the user is not a valid koha user
119
        # If we reach this point, the user is not a valid koha user
123
         $debug and warn "User with $config->{matchpoint} of $match is not a valid Koha user";
120
        Koha::Logger->get->info("There are several users with $config->{matchpoint} of $match, matchpoints must be unique");
124
        return 0;
121
        return 0;
125
    }
122
    }
126
}
123
}
Lines 163-190 sub _get_uri { Link Here
163
160
164
    my $protocol = "https://";
161
    my $protocol = "https://";
165
    my $interface = C4::Context->interface;
162
    my $interface = C4::Context->interface;
166
    $debug and warn "shibboleth interface: " . $interface;
167
163
168
    my $uri;
164
    my $uri =
169
    if ( $interface eq 'intranet' ) {
165
      $interface eq 'intranet'
166
      ? C4::Context->preference('staffClientBaseURL')
167
      : C4::Context->preference('OPACBaseURL');
170
168
171
        $uri = C4::Context->preference('staffClientBaseURL') // '';
169
    $uri or Koha::Logger->get->warn("Syspref staffClientBaseURL or OPACBaseURL not set!"); # FIXME We should die here
172
        if ($uri eq '') {
170
173
            $debug and warn 'staffClientBaseURL not set!';
171
    $uri ||= "";
174
        }
175
    } else {
176
        $uri = C4::Context->preference('OPACBaseURL') // '';
177
        if ($uri eq '') {
178
            $debug and warn 'OPACBaseURL not set!';
179
        }
180
    }
181
172
182
    if ($uri =~ /(.*):\/\/(.*)/) {
173
    if ($uri =~ /(.*):\/\/(.*)/) {
183
        my $oldprotocol = $1;
174
        my $oldprotocol = $1;
184
        if ($oldprotocol ne 'https') {
175
        if ($oldprotocol ne 'https') {
185
            $debug
176
            Koha::Logger->get->warn('Shibboleth requires OPACBaseURL/staffClientBaseURL to use the https protocol!');
186
                and warn
187
                  'Shibboleth requires OPACBaseURL/staffClientBaseURL to use the https protocol!';
188
        }
177
        }
189
        $uri = $2;
178
        $uri = $2;
190
    }
179
    }
Lines 217-234 sub _get_shib_config { Link Here
217
    my $config = C4::Context->config('shibboleth');
206
    my $config = C4::Context->config('shibboleth');
218
207
219
    if ( !$config ) {
208
    if ( !$config ) {
220
        carp 'shibboleth config not defined' if $debug;
209
        Koha::Logger->get->warn('shibboleth config not defined');
221
        return 0;
210
        return 0;
222
    }
211
    }
223
212
224
    if ( $config->{matchpoint}
213
    if ( $config->{matchpoint}
225
        && defined( $config->{mapping}->{ $config->{matchpoint} }->{is} ) )
214
        && defined( $config->{mapping}->{ $config->{matchpoint} }->{is} ) )
226
    {
215
    {
227
        if ($debug) {
216
        my $logger = Koha::Logger->get;
228
            warn "koha borrower field to match: " . $config->{matchpoint};
217
        $logger->debug("koha borrower field to match: " . $config->{matchpoint});
229
            warn "shibboleth attribute to match: "
218
        $logger->debug("shibboleth attribute to match: " . $config->{mapping}->{ $config->{matchpoint} }->{is});
230
              . $config->{mapping}->{ $config->{matchpoint} }->{is};
231
        }
232
        return $config;
219
        return $config;
233
    }
220
    }
234
    else {
221
    else {
(-)a/C4/CourseReserves.pm (-31 / +1 lines)
Lines 27-33 use Koha::Course::Instructors; Link Here
27
use Koha::Course::Items;
27
use Koha::Course::Items;
28
use Koha::Course::Reserves;
28
use Koha::Course::Reserves;
29
29
30
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG @FIELDS);
30
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS @FIELDS);
31
31
32
BEGIN {
32
BEGIN {
33
    require Exporter;
33
    require Exporter;
Lines 55-61 BEGIN { Link Here
55
    );
55
    );
56
    %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
56
    %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
57
57
58
    $DEBUG = 0;
59
    @FIELDS = ( 'itype', 'ccode', 'homebranch', 'holdingbranch', 'location' );
58
    @FIELDS = ( 'itype', 'ccode', 'homebranch', 'holdingbranch', 'location' );
60
}
59
}
61
60
Lines 81-87 This module deals with course reserves. Link Here
81
80
82
sub GetCourse {
81
sub GetCourse {
83
    my ($course_id) = @_;
82
    my ($course_id) = @_;
84
    warn whoami() . "( $course_id )" if $DEBUG;
85
83
86
    my $course = Koha::Courses->find( $course_id );
84
    my $course = Koha::Courses->find( $course_id );
87
    return unless $course;
85
    return unless $course;
Lines 108-114 sub GetCourse { Link Here
108
106
109
sub ModCourse {
107
sub ModCourse {
110
    my (%params) = @_;
108
    my (%params) = @_;
111
    warn identify_myself(%params) if $DEBUG;
112
109
113
    my $dbh = C4::Context->dbh;
110
    my $dbh = C4::Context->dbh;
114
111
Lines 158-164 sub ModCourse { Link Here
158
155
159
sub GetCourses {
156
sub GetCourses {
160
    my (%params) = @_;
157
    my (%params) = @_;
161
    warn identify_myself(%params) if $DEBUG;
162
158
163
    my @query_keys;
159
    my @query_keys;
164
    my @query_values;
160
    my @query_values;
Lines 241-247 sub DelCourse { Link Here
241
237
242
sub EnableOrDisableCourseItems {
238
sub EnableOrDisableCourseItems {
243
    my (%params) = @_;
239
    my (%params) = @_;
244
    warn identify_myself(%params) if $DEBUG;
245
240
246
    my $course_id = $params{'course_id'};
241
    my $course_id = $params{'course_id'};
247
    my $enabled = $params{'enabled'} || 0;
242
    my $enabled = $params{'enabled'} || 0;
Lines 290-296 sub EnableOrDisableCourseItems { Link Here
290
285
291
sub EnableOrDisableCourseItem {
286
sub EnableOrDisableCourseItem {
292
    my (%params) = @_;
287
    my (%params) = @_;
293
    warn identify_myself(%params) if $DEBUG;
294
288
295
    my $ci_id   = $params{'ci_id'};
289
    my $ci_id   = $params{'ci_id'};
296
290
Lines 329-336 sub EnableOrDisableCourseItem { Link Here
329
323
330
sub GetCourseInstructors {
324
sub GetCourseInstructors {
331
    my ($course_id) = @_;
325
    my ($course_id) = @_;
332
    warn "C4::CourseReserves::GetCourseInstructors( $course_id )"
333
      if $DEBUG;
334
326
335
    my $query = "
327
    my $query = "
336
        SELECT * FROM borrowers
328
        SELECT * FROM borrowers
Lines 359-365 sub GetCourseInstructors { Link Here
359
351
360
sub ModCourseInstructors {
352
sub ModCourseInstructors {
361
    my (%params) = @_;
353
    my (%params) = @_;
362
    warn identify_myself(%params) if $DEBUG;
363
354
364
    my $course_id       = $params{'course_id'};
355
    my $course_id       = $params{'course_id'};
365
    my $mode            = $params{'mode'};
356
    my $mode            = $params{'mode'};
Lines 420-426 sub ModCourseInstructors { Link Here
420
411
421
sub GetCourseItem {
412
sub GetCourseItem {
422
    my (%params) = @_;
413
    my (%params) = @_;
423
    warn identify_myself(%params) if $DEBUG;
424
414
425
    my $ci_id      = $params{'ci_id'};
415
    my $ci_id      = $params{'ci_id'};
426
    my $itemnumber = $params{'itemnumber'};
416
    my $itemnumber = $params{'itemnumber'};
Lines 459-465 sub GetCourseItem { Link Here
459
449
460
sub ModCourseItem {
450
sub ModCourseItem {
461
    my (%params) = @_;
451
    my (%params) = @_;
462
    warn identify_myself(%params) if $DEBUG;
463
452
464
    my $itemnumber = $params{'itemnumber'};
453
    my $itemnumber = $params{'itemnumber'};
465
454
Lines 493-499 sub ModCourseItem { Link Here
493
482
494
sub _AddCourseItem {
483
sub _AddCourseItem {
495
    my (%params) = @_;
484
    my (%params) = @_;
496
    warn identify_myself(%params) if $DEBUG;
497
485
498
    $params{homebranch} ||= undef; # Can't be empty string, FK constraint
486
    $params{homebranch} ||= undef; # Can't be empty string, FK constraint
499
    $params{holdingbranch} ||= undef; # Can't be empty string, FK constraint
487
    $params{holdingbranch} ||= undef; # Can't be empty string, FK constraint
Lines 520-526 sub _AddCourseItem { Link Here
520
508
521
sub _UpdateCourseItem {
509
sub _UpdateCourseItem {
522
    my (%params) = @_;
510
    my (%params) = @_;
523
    warn identify_myself(%params) if $DEBUG;
524
511
525
    my $ci_id         = $params{'ci_id'};
512
    my $ci_id         = $params{'ci_id'};
526
    my $course_item   = $params{'course_item'};
513
    my $course_item   = $params{'course_item'};
Lines 581-587 sub _UpdateCourseItem { Link Here
581
568
582
sub _RevertFields {
569
sub _RevertFields {
583
    my (%params) = @_;
570
    my (%params) = @_;
584
    warn identify_myself(%params) if $DEBUG;
585
571
586
    my $ci_id = $params{'ci_id'};
572
    my $ci_id = $params{'ci_id'};
587
573
Lines 617-623 sub _RevertFields { Link Here
617
603
618
sub _SwapAllFields {
604
sub _SwapAllFields {
619
    my ( $ci_id, $enabled ) = @_;
605
    my ( $ci_id, $enabled ) = @_;
620
    warn "C4::CourseReserves::_SwapFields( $ci_id )" if $DEBUG;
621
606
622
    my $course_item = Koha::Course::Items->find( $ci_id );
607
    my $course_item = Koha::Course::Items->find( $ci_id );
623
    my $item = Koha::Items->find( $course_item->itemnumber );
608
    my $item = Koha::Items->find( $course_item->itemnumber );
Lines 675-681 sub _SwapAllFields { Link Here
675
660
676
sub GetCourseItems {
661
sub GetCourseItems {
677
    my (%params) = @_;
662
    my (%params) = @_;
678
    warn identify_myself(%params) if $DEBUG;
679
663
680
    my $course_id  = $params{'course_id'};
664
    my $course_id  = $params{'course_id'};
681
    my $itemnumber = $params{'itemnumber'};
665
    my $itemnumber = $params{'itemnumber'};
Lines 714-720 sub GetCourseItems { Link Here
714
698
715
sub DelCourseItem {
699
sub DelCourseItem {
716
    my (%params) = @_;
700
    my (%params) = @_;
717
    warn identify_myself(%params) if $DEBUG;
718
701
719
    my $ci_id = $params{'ci_id'};
702
    my $ci_id = $params{'ci_id'};
720
703
Lines 740-746 sub DelCourseItem { Link Here
740
723
741
sub GetCourseReserve {
724
sub GetCourseReserve {
742
    my (%params) = @_;
725
    my (%params) = @_;
743
    warn identify_myself(%params) if $DEBUG;
744
726
745
    my $cr_id     = $params{'cr_id'};
727
    my $cr_id     = $params{'cr_id'};
746
    my $course_id = $params{'course_id'};
728
    my $course_id = $params{'course_id'};
Lines 779-785 sub GetCourseReserve { Link Here
779
761
780
sub ModCourseReserve {
762
sub ModCourseReserve {
781
    my (%params) = @_;
763
    my (%params) = @_;
782
    warn identify_myself(%params) if $DEBUG;
783
764
784
    my $course_id   = $params{'course_id'};
765
    my $course_id   = $params{'course_id'};
785
    my $ci_id       = $params{'ci_id'};
766
    my $ci_id       = $params{'ci_id'};
Lines 836-842 sub ModCourseReserve { Link Here
836
817
837
sub GetCourseReserves {
818
sub GetCourseReserves {
838
    my (%params) = @_;
819
    my (%params) = @_;
839
    warn identify_myself(%params) if $DEBUG;
840
820
841
    my $course_id       = $params{'course_id'};
821
    my $course_id       = $params{'course_id'};
842
    my $ci_id           = $params{'ci_id'};
822
    my $ci_id           = $params{'ci_id'};
Lines 897-903 sub GetCourseReserves { Link Here
897
877
898
sub DelCourseReserve {
878
sub DelCourseReserve {
899
    my (%params) = @_;
879
    my (%params) = @_;
900
    warn identify_myself(%params) if $DEBUG;
901
880
902
    my $cr_id = $params{'cr_id'};
881
    my $cr_id = $params{'cr_id'};
903
882
Lines 932-938 sub DelCourseReserve { Link Here
932
911
933
sub GetItemCourseReservesInfo {
912
sub GetItemCourseReservesInfo {
934
    my (%params) = @_;
913
    my (%params) = @_;
935
    warn identify_myself(%params) if $DEBUG;
936
914
937
    my $itemnumber = $params{'itemnumber'};
915
    my $itemnumber = $params{'itemnumber'};
938
916
Lines 967-973 sub GetItemCourseReservesInfo { Link Here
967
945
968
sub CountCourseReservesForItem {
946
sub CountCourseReservesForItem {
969
    my (%params) = @_;
947
    my (%params) = @_;
970
    warn identify_myself(%params) if $DEBUG;
971
948
972
    my $ci_id      = $params{'ci_id'};
949
    my $ci_id      = $params{'ci_id'};
973
    my $itemnumber = $params{'itemnumber'};
950
    my $itemnumber = $params{'itemnumber'};
Lines 1005-1011 sub CountCourseReservesForItem { Link Here
1005
982
1006
sub SearchCourses {
983
sub SearchCourses {
1007
    my (%params) = @_;
984
    my (%params) = @_;
1008
    warn identify_myself(%params) if $DEBUG;
1009
985
1010
    my $term = $params{'term'};
986
    my $term = $params{'term'};
1011
987
Lines 1076-1087 sub stringify_params { Link Here
1076
    return "( $string )";
1052
    return "( $string )";
1077
}
1053
}
1078
1054
1079
sub identify_myself {
1080
    my (%params) = @_;
1081
1082
    return whowasi() . stringify_params(%params);
1083
}
1084
1085
1;
1055
1;
1086
1056
1087
=head1 AUTHOR
1057
=head1 AUTHOR
(-)a/C4/Koha.pm (-4 / +1 lines)
Lines 30-36 use Koha::MarcSubfieldStructures; Link Here
30
use Business::ISBN;
30
use Business::ISBN;
31
use Business::ISSN;
31
use Business::ISSN;
32
use autouse 'Data::cselectall_arrayref' => qw(Dumper);
32
use autouse 'Data::cselectall_arrayref' => qw(Dumper);
33
use vars qw(@ISA @EXPORT @EXPORT_OK $DEBUG);
33
use vars qw(@ISA @EXPORT @EXPORT_OK);
34
34
35
BEGIN {
35
BEGIN {
36
	require Exporter;
36
	require Exporter;
Lines 57-65 BEGIN { Link Here
57
        &GetVariationsOfISSNs
57
        &GetVariationsOfISSNs
58
        &NormalizeISSN
58
        &NormalizeISSN
59
59
60
		$DEBUG
61
	);
60
	);
62
	$DEBUG = 0;
63
}
61
}
64
62
65
=head1 NAME
63
=head1 NAME
Lines 249-255 sub getImageSets { Link Here
249
    my @imagesets = (); # list of hasrefs of image set data to pass to template
247
    my @imagesets = (); # list of hasrefs of image set data to pass to template
250
    my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
248
    my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
251
    foreach my $imagesubdir ( @subdirectories ) {
249
    foreach my $imagesubdir ( @subdirectories ) {
252
    warn $imagesubdir if $DEBUG;
253
        my @imagelist     = (); # hashrefs of image info
250
        my @imagelist     = (); # hashrefs of image info
254
        my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
251
        my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
255
        my $imagesetactive = 0;
252
        my $imagesetactive = 0;
(-)a/C4/Languages.pm (-2 / +1 lines)
Lines 28-34 use List::MoreUtils qw( any ); Link Here
28
use C4::Context;
28
use C4::Context;
29
use Koha::Caches;
29
use Koha::Caches;
30
use Koha::Cache::Memory::Lite;
30
use Koha::Cache::Memory::Lite;
31
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
31
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
32
32
33
BEGIN {
33
BEGIN {
34
    require Exporter;
34
    require Exporter;
Lines 40-46 BEGIN { Link Here
40
        &getAllLanguages
40
        &getAllLanguages
41
    );
41
    );
42
    @EXPORT_OK = qw(getFrameworkLanguages getTranslatedLanguages getAllLanguages getLanguages get_bidi regex_lang_subtags language_get_description accept_language getlanguage);
42
    @EXPORT_OK = qw(getFrameworkLanguages getTranslatedLanguages getAllLanguages getLanguages get_bidi regex_lang_subtags language_get_description accept_language getlanguage);
43
    $DEBUG = 0;
44
}
43
}
45
44
46
=head1 NAME
45
=head1 NAME
(-)a/C4/MarcModificationTemplates.pm (-17 lines)
Lines 28-35 use Koha::DateUtils; Link Here
28
28
29
use vars qw(@ISA @EXPORT);
29
use vars qw(@ISA @EXPORT);
30
30
31
use constant DEBUG => 0;
32
33
BEGIN {
31
BEGIN {
34
    @ISA = qw(Exporter);
32
    @ISA = qw(Exporter);
35
    @EXPORT = qw(
33
    @EXPORT = qw(
Lines 75-81 files telling Koha what fields to insert data into. Link Here
75
73
76
sub GetModificationTemplates {
74
sub GetModificationTemplates {
77
  my ( $template_id ) = @_;
75
  my ( $template_id ) = @_;
78
  warn("C4::MarcModificationTemplates::GetModificationTemplates( $template_id )") if DEBUG;
79
76
80
  my $dbh = C4::Context->dbh;
77
  my $dbh = C4::Context->dbh;
81
  my $sth = $dbh->prepare("SELECT * FROM marc_modification_templates ORDER BY name");
78
  my $sth = $dbh->prepare("SELECT * FROM marc_modification_templates ORDER BY name");
Lines 182-189 sub GetModificationTemplateAction { Link Here
182
sub GetModificationTemplateActions {
179
sub GetModificationTemplateActions {
183
  my ( $template_id ) = @_;
180
  my ( $template_id ) = @_;
184
181
185
  warn( "C4::MarcModificationTemplates::GetModificationTemplateActions( $template_id )" ) if DEBUG;
186
187
  my $dbh = C4::Context->dbh;
182
  my $dbh = C4::Context->dbh;
188
  my $sth = $dbh->prepare("SELECT * FROM marc_modification_template_actions WHERE template_id = ? ORDER BY ordering");
183
  my $sth = $dbh->prepare("SELECT * FROM marc_modification_template_actions WHERE template_id = ? ORDER BY ordering");
189
  $sth->execute( $template_id );
184
  $sth->execute( $template_id );
Lines 193-200 sub GetModificationTemplateActions { Link Here
193
    push( @actions, $action );
188
    push( @actions, $action );
194
  }
189
  }
195
190
196
  warn( Data::Dumper::Dumper( @actions ) ) if DEBUG > 4;
197
198
  return @actions;
191
  return @actions;
199
}
192
}
200
193
Lines 236-246 sub AddModificationTemplateAction { Link Here
236
    $description
229
    $description
237
  ) = @_;
230
  ) = @_;
238
231
239
  warn( "C4::MarcModificationTemplates::AddModificationTemplateAction( $template_id, $action,
240
                    $field_number, $from_field, $from_subfield, $field_value, $to_field, $to_subfield,
241
                    $to_regex_search, $to_regex_replace, $to_regex_modifiers, $conditional, $conditional_field, $conditional_subfield, $conditional_comparison,
242
                    $conditional_value, $conditional_regex, $description )" ) if DEBUG;
243
244
  $conditional ||= undef;
232
  $conditional ||= undef;
245
  $conditional_comparison ||= undef;
233
  $conditional_comparison ||= undef;
246
  $conditional_regex ||= '0';
234
  $conditional_regex ||= '0';
Lines 481-487 sub MoveModificationTemplateAction { Link Here
481
469
482
sub ModifyRecordsWithTemplate {
470
sub ModifyRecordsWithTemplate {
483
  my ( $template_id, $batch ) = @_;
471
  my ( $template_id, $batch ) = @_;
484
  warn( "C4::MarcModificationTemplates::ModifyRecordsWithTemplate( $template_id, $batch )" ) if DEBUG;
485
472
486
  while ( my $record = $batch->next() ) {
473
  while ( my $record = $batch->next() ) {
487
    ModifyRecordWithTemplate( $template_id, $record );
474
    ModifyRecordWithTemplate( $template_id, $record );
Lines 499-506 sub ModifyRecordsWithTemplate { Link Here
499
486
500
sub ModifyRecordWithTemplate {
487
sub ModifyRecordWithTemplate {
501
    my ( $template_id, $record ) = @_;
488
    my ( $template_id, $record ) = @_;
502
    warn( "C4::MarcModificationTemplates::ModifyRecordWithTemplate( $template_id, $record )" ) if DEBUG;
503
    warn( "Unmodified Record:\n" . $record->as_formatted() ) if DEBUG >= 10;
504
489
505
    my $current_date = dt_from_string()->ymd();
490
    my $current_date = dt_from_string()->ymd();
506
    my $branchcode = '';
491
    my $branchcode = '';
Lines 705-712 sub ModifyRecordWithTemplate { Link Here
705
                });
690
                });
706
            }
691
            }
707
        }
692
        }
708
709
        warn( $record->as_formatted() ) if DEBUG >= 10;
710
    }
693
    }
711
694
712
    return;
695
    return;
(-)a/C4/Members.pm (-4 / +1 lines)
Lines 44-53 use Koha::List::Patron; Link Here
44
use Koha::Patrons;
44
use Koha::Patrons;
45
use Koha::Patron::Categories;
45
use Koha::Patron::Categories;
46
46
47
our (@ISA,@EXPORT,@EXPORT_OK,$debug);
47
our (@ISA,@EXPORT,@EXPORT_OK);
48
48
49
BEGIN {
49
BEGIN {
50
    $debug = $ENV{DEBUG} || 0;
51
    require Exporter;
50
    require Exporter;
52
    @ISA = qw(Exporter);
51
    @ISA = qw(Exporter);
53
    #Get data
52
    #Get data
Lines 450-457 sub GetBorrowersToExpunge { Link Here
450
        push( @query_params, $anonymous_patron );
449
        push( @query_params, $anonymous_patron );
451
    }
450
    }
452
451
453
    warn $query if $debug;
454
455
    my $sth = $dbh->prepare($query);
452
    my $sth = $dbh->prepare($query);
456
    if (scalar(@query_params)>0){
453
    if (scalar(@query_params)>0){
457
        $sth->execute(@query_params);
454
        $sth->execute(@query_params);
(-)a/C4/Members/Statistics.pm (-2 / +1 lines)
Lines 26-35 use Modern::Perl; Link Here
26
26
27
use C4::Context;
27
use C4::Context;
28
28
29
our ( @ISA, @EXPORT, @EXPORT_OK, $debug );
29
our ( @ISA, @EXPORT, @EXPORT_OK );
30
30
31
BEGIN {
31
BEGIN {
32
    $debug = $ENV{DEBUG} || 0;
33
    require Exporter;
32
    require Exporter;
34
    @ISA = qw(Exporter);
33
    @ISA = qw(Exporter);
35
34
(-)a/C4/Patroncards/Patroncard.pm (-1 lines)
Lines 260-266 sub draw_text { Link Here
260
            while (1) {
260
            while (1) {
261
#                $line =~ m/^.*(\s\b.*\b\s*|\s&|\<\b.*\b\>)$/; # original regexp... can be removed after dev stage is over
261
#                $line =~ m/^.*(\s\b.*\b\s*|\s&|\<\b.*\b\>)$/; # original regexp... can be removed after dev stage is over
262
                $line =~ m/^.*(\s.*\s*|\s&|\<.*\>)$/;
262
                $line =~ m/^.*(\s.*\s*|\s&|\<.*\>)$/;
263
                warn sprintf('Line wrap failed. DEBUG INFO: Data: \'%s\'\n Method: C4::Patroncards->draw_text Additional Information: Line wrap regexp failed. (Please file in this information in a bug report at http://bugs.koha-community.org', $line) and last WRAP_LINES if !$1;
264
                $trim = $1 . $trim;
263
                $trim = $1 . $trim;
265
                #Sanitize the input into this regular expression so regex metacharacters are escaped as literal values (https://bugs.koha-community.org/bugzilla3/show_bug.cgi?id=22429)
264
                #Sanitize the input into this regular expression so regex metacharacters are escaped as literal values (https://bugs.koha-community.org/bugzilla3/show_bug.cgi?id=22429)
266
                $line =~ s/\Q$1\E$//;
265
                $line =~ s/\Q$1\E$//;
(-)a/C4/SIP/ILS.pm (-6 lines)
Lines 19-26 use C4::SIP::ILS::Transaction::Hold; Link Here
19
use C4::SIP::ILS::Transaction::Renew;
19
use C4::SIP::ILS::Transaction::Renew;
20
use C4::SIP::ILS::Transaction::RenewAll;
20
use C4::SIP::ILS::Transaction::RenewAll;
21
21
22
my $debug = 0;
23
24
my %supports = (
22
my %supports = (
25
    'magnetic media'        => 1,
23
    'magnetic media'        => 1,
26
    'security inhibit'      => 0,
24
    'security inhibit'      => 0,
Lines 46-52 sub new { Link Here
46
    my ($class, $institution) = @_;
44
    my ($class, $institution) = @_;
47
    my $type = ref($class) || $class;
45
    my $type = ref($class) || $class;
48
    my $self = {};
46
    my $self = {};
49
	$debug and warn "new ILS: INSTITUTION: " . Dumper($institution);
50
    siplog("LOG_DEBUG", "new ILS '%s'", $institution->{id});
47
    siplog("LOG_DEBUG", "new ILS '%s'", $institution->{id});
51
    $self->{institution} = $institution;
48
    $self->{institution} = $institution;
52
    return bless $self, $type;
49
    return bless $self, $type;
Lines 54-66 sub new { Link Here
54
51
55
sub find_patron {
52
sub find_patron {
56
    my $self = shift;
53
    my $self = shift;
57
 	$debug and warn "ILS: finding patron";
58
    return C4::SIP::ILS::Patron->new(@_);
54
    return C4::SIP::ILS::Patron->new(@_);
59
}
55
}
60
56
61
sub find_item {
57
sub find_item {
62
    my $self = shift;
58
    my $self = shift;
63
	$debug and warn "ILS: finding item";
64
    return C4::SIP::ILS::Item->new(@_);
59
    return C4::SIP::ILS::Item->new(@_);
65
}
60
}
66
61
Lines 155-161 sub checkout { Link Here
155
    else {
150
    else {
156
        $circ->do_checkout($account);
151
        $circ->do_checkout($account);
157
        if ( $circ->ok ) {
152
        if ( $circ->ok ) {
158
            $debug and warn "circ is ok";
159
153
160
            # If the item is already associated with this patron, then
154
            # If the item is already associated with this patron, then
161
            # we're renewing it.
155
            # we're renewing it.
(-)a/C4/SIP/ILS/Transaction/FeePayment.pm (-2 lines)
Lines 25-32 use Koha::Account::Lines; Link Here
25
25
26
use parent qw(C4::SIP::ILS::Transaction);
26
use parent qw(C4::SIP::ILS::Transaction);
27
27
28
our $debug = 0;
29
30
my %fields = ();
28
my %fields = ();
31
29
32
sub new {
30
sub new {
(-)a/C4/SIP/Sip/Checksum.pm (-4 / +1 lines)
Lines 6-12 use warnings; Link Here
6
6
7
our @ISA = qw(Exporter);
7
our @ISA = qw(Exporter);
8
our @EXPORT_OK = qw(checksum verify_cksum);
8
our @EXPORT_OK = qw(checksum verify_cksum);
9
our $debug = 0;
10
9
11
sub checksum {
10
sub checksum {
12
    my $pkt = shift;
11
    my $pkt = shift;
Lines 18-26 sub verify_cksum { Link Here
18
    my $cksum;
17
    my $cksum;
19
    my $shortsum;
18
    my $shortsum;
20
19
21
	if ($pkt =~ /AZ(....)$/) {
20
    unless ($pkt =~ /AZ(....)$/) {
22
		$debug and warn "verify_cksum: sum ($1) detected";
23
	} else {
24
		warn "verify_cksum: no sum detected";
21
		warn "verify_cksum: no sum detected";
25
		return 0; # No checksum at end
22
		return 0; # No checksum at end
26
	}
23
	}
(-)a/C4/Service.pm (-7 lines)
Lines 47-58 use C4::Output qw( :ajax ); Link Here
47
use C4::Output::JSONStream;
47
use C4::Output::JSONStream;
48
use JSON;
48
use JSON;
49
49
50
our $debug;
51
52
BEGIN {
53
    $debug = $ENV{DEBUG} || 0;
54
}
55
56
our ( $query, $cookie );
50
our ( $query, $cookie );
57
51
58
sub _output {
52
sub _output {
Lines 257-263 sub dispatch { Link Here
257
            next ROUTE if ( !defined( $query->param ( $param ) ) );
251
            next ROUTE if ( !defined( $query->param ( $param ) ) );
258
        }
252
        }
259
253
260
        $debug and warn "Using $path";
261
        $handler->( @match );
254
        $handler->( @match );
262
        return;
255
        return;
263
    }
256
    }
(-)a/Koha/Cache.pm (-11 lines)
Lines 73-80 sub new { Link Here
73
73
74
    my $subnamespace = $params->{subnamespace} // '';
74
    my $subnamespace = $params->{subnamespace} // '';
75
75
76
    $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
77
78
    $self->{'timeout'}   ||= 0;
76
    $self->{'timeout'}   ||= 0;
79
    # Should we continue to support MEMCACHED ENV vars?
77
    # Should we continue to support MEMCACHED ENV vars?
80
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE};
78
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE};
Lines 92-99 sub new { Link Here
92
        $self->{'cache'} = $self->{'memcached_cache'};
90
        $self->{'cache'} = $self->{'memcached_cache'};
93
    }
91
    }
94
92
95
    $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
96
97
    return
93
    return
98
      bless $self,
94
      bless $self,
99
      $class;
95
      $class;
Lines 104-114 sub _initialize_memcached { Link Here
104
100
105
    return unless @servers;
101
    return unless @servers;
106
102
107
    $ENV{DEBUG}
108
      && carp "Memcached server settings: "
109
      . join( ', ', @servers )
110
      . " with "
111
      . $self->{'namespace'};
112
    # Cache::Memcached::Fast::Safe doesn't allow a default expire time to be set
103
    # Cache::Memcached::Fast::Safe doesn't allow a default expire time to be set
113
    # so we force it on setting.
104
    # so we force it on setting.
114
    my $memcached = Cache::Memcached::Fast::Safe->new(
105
    my $memcached = Cache::Memcached::Fast::Safe->new(
Lines 177-183 sub set_in_cache { Link Here
177
168
178
    my $cache = $options->{cache} || 'cache';
169
    my $cache = $options->{cache} || 'cache';
179
    croak "No key" unless $key;
170
    croak "No key" unless $key;
180
    $ENV{DEBUG} && carp "set_in_cache for $key";
181
171
182
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
172
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
183
    my $expiry = $options->{expiry};
173
    my $expiry = $options->{expiry};
Lines 245-251 sub get_from_cache { Link Here
245
    my $unsafe = $options->{unsafe} || 0;
235
    my $unsafe = $options->{unsafe} || 0;
246
    $key =~ s/[\x00-\x20]/_/g;
236
    $key =~ s/[\x00-\x20]/_/g;
247
    croak "No key" unless $key;
237
    croak "No key" unless $key;
248
    $ENV{DEBUG} && carp "get_from_cache for $key";
249
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
238
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
250
239
251
    # Return L1 cache value if exists
240
    # Return L1 cache value if exists
(-)a/Koha/Cache/Object.pm (-4 lines)
Lines 81-90 sub TIESCALAR { Link Here
81
sub FETCH {
81
sub FETCH {
82
    my ( $self, $index ) = @_;
82
    my ( $self, $index ) = @_;
83
83
84
    $ENV{DEBUG}
85
      && $index
86
      && carp "Retrieving cached hash member $index of $self->{'key'}";
87
88
    my $now = time;
84
    my $now = time;
89
85
90
    if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
86
    if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
(-)a/Koha/SimpleMARC.pm (-2 lines)
Lines 42-49 our @EXPORT = qw( Link Here
42
);
42
);
43
43
44
44
45
our $debug = 0;
46
47
=head1 NAME
45
=head1 NAME
48
46
49
SimpleMARC - Perl module for making simple MARC record alterations.
47
SimpleMARC - Perl module for making simple MARC record alterations.
(-)a/Koha/XSLT/Base.pm (-2 / +1 lines)
Lines 66-73 Koha::XSLT::Base - Facilitate use of XSLT transformations Link Here
66
66
67
=head2 print_warns
67
=head2 print_warns
68
68
69
    If set, print error messages to STDERR. False by default. Looks at the
69
    If set, print error messages to STDERR. False by default.
70
    DEBUG environment variable too.
71
70
72
=head1 ERROR CODES
71
=head1 ERROR CODES
73
72
(-)a/catalogue/detail.pl (-2 lines)
Lines 502-509 $template->param( Link Here
502
    searchid            => scalar $query->param('searchid'),
502
    searchid            => scalar $query->param('searchid'),
503
);
503
);
504
504
505
# $debug and $template->param(debug_display => 1);
506
507
# Lists
505
# Lists
508
506
509
if (C4::Context->preference("virtualshelves") ) {
507
if (C4::Context->preference("virtualshelves") ) {
(-)a/catalogue/image.pl (-3 lines)
Lines 33-39 use Koha::Exceptions; Link Here
33
33
34
$| = 1;
34
$| = 1;
35
35
36
my $DEBUG = 0;
37
my $data  = CGI->new;
36
my $data  = CGI->new;
38
my $imagenumber;
37
my $imagenumber;
39
38
Lines 73-80 if ( C4::Context->preference("LocalCoverImages") ) { Link Here
73
        my $cover_images = $biblio->cover_images;
72
        my $cover_images = $biblio->cover_images;
74
        if ( $cover_images->count ) {
73
        if ( $cover_images->count ) {
75
            $image = $cover_images->next;
74
            $image = $cover_images->next;
76
        } else {
77
            warn "No images for this biblio" if $DEBUG;
78
        }
75
        }
79
    }
76
    }
80
}
77
}
(-)a/cataloguing/value_builder/barcode.pl (-3 lines)
Lines 29-36 use Koha::DateUtils; Link Here
29
29
30
use Algorithm::CheckDigits;
30
use Algorithm::CheckDigits;
31
31
32
my $DEBUG = 0;
33
34
my $builder = sub {
32
my $builder = sub {
35
    my ( $params ) = @_;
33
    my ( $params ) = @_;
36
    my $function_name = $params->{id};
34
    my $function_name = $params->{id};
Lines 44-50 my $builder = sub { Link Here
44
	my $nextnum;
42
	my $nextnum;
45
    my $scr;
43
    my $scr;
46
	my $autoBarcodeType = C4::Context->preference("autoBarcode");
44
	my $autoBarcodeType = C4::Context->preference("autoBarcode");
47
    warn "Barcode type = $autoBarcodeType" if $DEBUG;
48
	if ((not $autoBarcodeType) or $autoBarcodeType eq 'OFF') {
45
	if ((not $autoBarcodeType) or $autoBarcodeType eq 'OFF') {
49
        # don't return a value unless we have the appropriate syspref set
46
        # don't return a value unless we have the appropriate syspref set
50
        return q|<script></script>|;
47
        return q|<script></script>|;
(-)a/cataloguing/value_builder/barcode_manual.pl (-3 lines)
Lines 27-34 use C4::Barcodes::ValueBuilder; Link Here
27
use C4::Biblio qw/GetMarcFromKohaField/;
27
use C4::Biblio qw/GetMarcFromKohaField/;
28
use Koha::DateUtils;
28
use Koha::DateUtils;
29
29
30
my $DEBUG = 0;
31
32
my $builder = sub {
30
my $builder = sub {
33
    my ( $params ) = @_;
31
    my ( $params ) = @_;
34
    my $function_name = $params->{id};
32
    my $function_name = $params->{id};
Lines 45-51 my $builder = sub { Link Here
45
    my $nextnum;
43
    my $nextnum;
46
    my $scr;
44
    my $scr;
47
    my $autoBarcodeType = C4::Context->preference("autoBarcode");
45
    my $autoBarcodeType = C4::Context->preference("autoBarcode");
48
    warn "Barcode type = $autoBarcodeType" if $DEBUG;
49
    if ((not $autoBarcodeType) or $autoBarcodeType eq 'OFF') {
46
    if ((not $autoBarcodeType) or $autoBarcodeType eq 'OFF') {
50
# don't return a value unless we have the appropriate syspref set
47
# don't return a value unless we have the appropriate syspref set
51
        return q|<script></script>|;
48
        return q|<script></script>|;
(-)a/circ/hold-transfer-slip.pl (-7 lines)
Lines 25-36 use CGI qw ( -utf8 ); Link Here
25
use C4::Auth qw/:DEFAULT get_session/;
25
use C4::Auth qw/:DEFAULT get_session/;
26
use C4::Reserves;
26
use C4::Reserves;
27
27
28
use vars qw($debug);
29
30
BEGIN {
31
    $debug = $ENV{DEBUG} || 0;
32
}
33
34
my $input = CGI->new;
28
my $input = CGI->new;
35
my $sessionID = $input->cookie("CGISESSID");
29
my $sessionID = $input->cookie("CGISESSID");
36
my $session = get_session($sessionID);
30
my $session = get_session($sessionID);
Lines 43-49 my ( $template, $loggedinuser, $cookie ) = get_template_and_user( Link Here
43
        query           => $input,
37
        query           => $input,
44
        type            => "intranet",
38
        type            => "intranet",
45
        flagsrequired   => { circulate => "circulate_remaining_permissions" },
39
        flagsrequired   => { circulate => "circulate_remaining_permissions" },
46
        debug           => $debug,
47
    }
40
    }
48
);
41
);
49
42
(-)a/circ/transfer-slip.pl (-7 lines)
Lines 26-37 use CGI qw ( -utf8 ); Link Here
26
use C4::Auth qw/:DEFAULT get_session/;
26
use C4::Auth qw/:DEFAULT get_session/;
27
use C4::Circulation;
27
use C4::Circulation;
28
28
29
use vars qw($debug);
30
31
BEGIN {
32
    $debug = $ENV{DEBUG} || 0;
33
}
34
35
my $input = CGI->new;
29
my $input = CGI->new;
36
my $sessionID = $input->cookie("CGISESSID");
30
my $sessionID = $input->cookie("CGISESSID");
37
my $session = get_session($sessionID);
31
my $session = get_session($sessionID);
Lines 46-52 my ( $template, $loggedinuser, $cookie ) = get_template_and_user( Link Here
46
        query           => $input,
40
        query           => $input,
47
        type            => "intranet",
41
        type            => "intranet",
48
        flagsrequired   => { circulate => "circulate_remaining_permissions" },
42
        flagsrequired   => { circulate => "circulate_remaining_permissions" },
49
        debug           => $debug,
50
    }
43
    }
51
);
44
);
52
45
(-)a/fix-perl-path.PL (-1 / +1 lines)
Lines 20-26 use ExtUtils::MakeMaker::Config; Link Here
20
use Tie::File;
20
use Tie::File;
21
21
22
my $basedir = (shift);
22
my $basedir = (shift);
23
my $DEBUG = exists $ENV{'DEBUG'} ? $ENV{'DEBUG'} : 0;
23
my $DEBUG = 0;
24
24
25
$DEBUG = 1 if $basedir eq 'test';
25
$DEBUG = 1 if $basedir eq 'test';
26
26
(-)a/installer/data/mysql/updatedatabase.pl (-2 lines)
Lines 50-57 use File::Slurp; Link Here
50
# FIXME - The user might be installing a new database, so can't rely
50
# FIXME - The user might be installing a new database, so can't rely
51
# on /etc/koha.conf anyway.
51
# on /etc/koha.conf anyway.
52
52
53
my $debug = 0;
54
55
my (
53
my (
56
    $sth,
54
    $sth,
57
    $query,
55
    $query,
(-)a/koha-tmpl/opac-tmpl/bootstrap/en/modules/opac-shelves.tt (-4 lines)
Lines 817-826 Link Here
817
    <input type="hidden" name="format" id="download_format" value="" />
817
    <input type="hidden" name="format" id="download_format" value="" />
818
</form>
818
</form>
819
819
820
<!-- DEBUG -->
821
    <div id="debug"></div>
822
<!-- /DEBUG -->
823
824
[% INCLUDE 'opac-bottom.inc' %]
820
[% INCLUDE 'opac-bottom.inc' %]
825
[% BLOCK jsinclude %]
821
[% BLOCK jsinclude %]
826
[% Asset.js("lib/hc-sticky.js") | $raw %]
822
[% Asset.js("lib/hc-sticky.js") | $raw %]
(-)a/labels/label-edit-batch.pl (-1 lines)
Lines 19-25 Link Here
19
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
# along with Koha; if not, see <http://www.gnu.org/licenses>.
20
20
21
use Modern::Perl;
21
use Modern::Perl;
22
use vars qw($debug);
23
22
24
use CGI qw ( -utf8 );
23
use CGI qw ( -utf8 );
25
24
(-)a/labels/label-manage.pl (-2 lines)
Lines 20-27 Link Here
20
20
21
use Modern::Perl;
21
use Modern::Perl;
22
22
23
use vars qw($debug);
24
25
use CGI qw ( -utf8 );
23
use CGI qw ( -utf8 );
26
use Data::Dumper;
24
use Data::Dumper;
27
25
(-)a/members/memberentry.pl (-13 / +1 lines)
Lines 49-62 use Koha::Token; Link Here
49
use Email::Valid;
49
use Email::Valid;
50
use Koha::SMS::Providers;
50
use Koha::SMS::Providers;
51
51
52
use vars qw($debug);
53
54
BEGIN {
55
	$debug = $ENV{DEBUG} || 0;
56
}
57
	
58
my $input = CGI->new;
52
my $input = CGI->new;
59
($debug) or $debug = $input->param('debug') || 0;
60
my %data;
53
my %data;
61
54
62
my $dbh = C4::Context->dbh;
55
my $dbh = C4::Context->dbh;
Lines 66-72 my ($template, $loggedinuser, $cookie) Link Here
66
           query => $input,
59
           query => $input,
67
           type => "intranet",
60
           type => "intranet",
68
           flagsrequired => {borrowers => 'edit_borrowers'},
61
           flagsrequired => {borrowers => 'edit_borrowers'},
69
           debug => ($debug) ? 1 : 0,
70
       });
62
       });
71
63
72
my $borrowernumber = $input->param('borrowernumber');
64
my $borrowernumber = $input->param('borrowernumber');
Lines 319-326 if ( ( defined $newdata{'userid'} && $newdata{'userid'} eq '' ) || $check_Borrow Link Here
319
        $newdata{'userid'} = $data{'userid'};
311
        $newdata{'userid'} = $data{'userid'};
320
    }
312
    }
321
}
313
}
322
  
314
323
$debug and warn join "\t", map {"$_: $newdata{$_}"} qw(dateofbirth dateenrolled dateexpiry);
324
my $extended_patron_attributes;
315
my $extended_patron_attributes;
325
if ($op eq 'save' || $op eq 'insert'){
316
if ($op eq 'save' || $op eq 'insert'){
326
317
Lines 363-369 if ($op eq 'save' || $op eq 'insert'){ Link Here
363
  
354
  
364
  if (C4::Context->preference("IndependentBranches")) {
355
  if (C4::Context->preference("IndependentBranches")) {
365
    unless ( C4::Context->IsSuperLibrarian() ){
356
    unless ( C4::Context->IsSuperLibrarian() ){
366
      $debug and print STDERR "  $newdata{'branchcode'} : ".$userenv->{flags}.":".$userenv->{branch};
367
      unless (!$newdata{'branchcode'} || $userenv->{branch} eq $newdata{'branchcode'}){
357
      unless (!$newdata{'branchcode'} || $userenv->{branch} eq $newdata{'branchcode'}){
368
        push @errors, "ERROR_branch";
358
        push @errors, "ERROR_branch";
369
      }
359
      }
Lines 444-450 if ( defined $sms ) { Link Here
444
###  Error checks should happen before this line.
434
###  Error checks should happen before this line.
445
$nok = $nok || scalar(@errors);
435
$nok = $nok || scalar(@errors);
446
if ((!$nok) and $nodouble and ($op eq 'insert' or $op eq 'save')){
436
if ((!$nok) and $nodouble and ($op eq 'insert' or $op eq 'save')){
447
	$debug and warn "$op dates: " . join "\t", map {"$_: $newdata{$_}"} qw(dateofbirth dateenrolled dateexpiry);
448
    my $success;
437
    my $success;
449
	if ($op eq 'insert'){
438
	if ($op eq 'insert'){
450
		# we know it's not a duplicate borrowernumber or there would already be an error
439
		# we know it's not a duplicate borrowernumber or there would already be an error
Lines 818-824 if (C4::Context->preference('EnhancedMessagingPreferences')) { Link Here
818
}
807
}
819
808
820
$template->param( "show_guarantor" => ( $category_type =~ /A|I|S|X/ ) ? 0 : 1 ); # associate with step to know where you are
809
$template->param( "show_guarantor" => ( $category_type =~ /A|I|S|X/ ) ? 0 : 1 ); # associate with step to know where you are
821
$debug and warn "memberentry step: $step";
822
$template->param(%data);
810
$template->param(%data);
823
$template->param( "step_$step"  => 1) if $step;	# associate with step to know where u are
811
$template->param( "step_$step"  => 1) if $step;	# associate with step to know where u are
824
$template->param(  step  => $step   ) if $step;	# associate with step to know where u are
812
$template->param(  step  => $step   ) if $step;	# associate with step to know where u are
(-)a/members/moremember.pl (-8 lines)
Lines 44-58 use Koha::Patron::Files; Link Here
44
use Koha::Token;
44
use Koha::Token;
45
use Koha::Checkouts;
45
use Koha::Checkouts;
46
46
47
use vars qw($debug);
48
49
BEGIN {
50
    $debug = $ENV{DEBUG} || 0;
51
}
52
53
my $input = CGI->new;
47
my $input = CGI->new;
54
$debug or $debug = $input->param('debug') || 0;
55
56
48
57
my $print = $input->param('print');
49
my $print = $input->param('print');
58
50
(-)a/members/patronimage.pl (-4 lines)
Lines 30-36 use Koha::Patron::Images; Link Here
30
30
31
$|=1;
31
$|=1;
32
32
33
my $DEBUG = 0;
34
my $query = CGI->new;
33
my $query = CGI->new;
35
my $borrowernumber;
34
my $borrowernumber;
36
35
Lines 63-71 if ($query->param('borrowernumber')) { Link Here
63
    $borrowernumber = shift;
62
    $borrowernumber = shift;
64
}
63
}
65
64
66
67
warn "Borrowernumber passed in: $borrowernumber" if $DEBUG;
68
69
my $patron_image = Koha::Patron::Images->find($borrowernumber);
65
my $patron_image = Koha::Patron::Images->find($borrowernumber);
70
66
71
# NOTE: Never dump the contents of $imagedata->{'patronimage'} via a warn to a log or nasty
67
# NOTE: Never dump the contents of $imagedata->{'patronimage'} via a warn to a log or nasty
(-)a/members/printslip.pl (-10 lines)
Lines 41-60 use C4::Members; Link Here
41
use C4::Koha;
41
use C4::Koha;
42
use Koha::DateUtils;
42
use Koha::DateUtils;
43
43
44
#use Smart::Comments;
45
#use Data::Dumper;
46
47
use vars qw($debug);
48
49
BEGIN {
50
	$debug = $ENV{DEBUG} || 0;
51
}
52
53
my $input = CGI->new;
44
my $input = CGI->new;
54
my $sessionID = $input->cookie("CGISESSID");
45
my $sessionID = $input->cookie("CGISESSID");
55
my $session = get_session($sessionID);
46
my $session = get_session($sessionID);
56
47
57
$debug or $debug = $input->param('debug') || 0;
58
my $print = $input->param('print');
48
my $print = $input->param('print');
59
my $error = $input->param('error');
49
my $error = $input->param('error');
60
50
(-)a/misc/cronjobs/staticfines.pl (-1 / +1 lines)
Lines 59-65 my $delay; Link Here
59
my $useborrowerlibrary;
59
my $useborrowerlibrary;
60
my $borrowernumberlimit;
60
my $borrowernumberlimit;
61
my $borrowersalreadyapplied; # hashref of borrowers for whom we already applied the fine, so it's only applied once
61
my $borrowersalreadyapplied; # hashref of borrowers for whom we already applied the fine, so it's only applied once
62
my $debug = $ENV{'DEBUG'} || 0;
62
my $debug = 0;
63
my $bigdebug = 0;
63
my $bigdebug = 0;
64
64
65
GetOptions(
65
GetOptions(
(-)a/misc/maintenance/UNIMARC_sync_date_created_with_marc_biblio.pl (-1 / +1 lines)
Lines 38-44 GetOptions( Link Here
38
    'date-created-marc|c:s'  => \$date_created_marc,
38
    'date-created-marc|c:s'  => \$date_created_marc,
39
    'date-modified-marc|m:s' => \$date_modified_marc,
39
    'date-modified-marc|m:s' => \$date_modified_marc,
40
);
40
);
41
my $debug = $ENV{DEBUG};
41
my $debug = 0; # FIXME pass an option for that?
42
$verbose = 1 if $debug;
42
$verbose = 1 if $debug;
43
43
44
# display help ?
44
# display help ?
(-)a/misc/migration_tools/koha-svc.pl (-1 / +1 lines)
Lines 30-36 if ( $#ARGV >= 3 && ! caller ) { # process command-line params only if not calle Link Here
30
        url      => $url,
30
        url      => $url,
31
        user     => $user,
31
        user     => $user,
32
        password => $password,
32
        password => $password,
33
        debug    => $ENV{DEBUG},
33
        debug    => 0,
34
    );
34
    );
35
35
36
    if ( ! $file ) {
36
    if ( ! $file ) {
(-)a/offline_circ/enqueue_koc.pl (-2 lines)
Lines 37-44 use Koha::Items; Link Here
37
37
38
use Date::Calc qw( Add_Delta_Days Date_to_Days );
38
use Date::Calc qw( Add_Delta_Days Date_to_Days );
39
39
40
use constant DEBUG => 0;
41
42
# this is the file version number that we're coded against.
40
# this is the file version number that we're coded against.
43
my $FILE_VERSION = '1.0';
41
my $FILE_VERSION = '1.0';
44
42
(-)a/offline_circ/process_koc.pl (-1 / +1 lines)
Lines 266-272 sub kocIssueItem { Link Here
266
                undef,                         # branch
266
                undef,                         # branch
267
                undef,                         # datedue - let AddRenewal calculate it automatically
267
                undef,                         # datedue - let AddRenewal calculate it automatically
268
                $circ->{'date'},               # issuedate
268
                $circ->{'date'},               # issuedate
269
            ) unless ($DEBUG);
269
            ) unless (DEBUG);
270
270
271
            push @output, {
271
            push @output, {
272
                renew => 1,
272
                renew => 1,
(-)a/opac/opac-image.pl (-3 lines)
Lines 32-38 use Koha::CoverImages; Link Here
32
32
33
$| = 1;
33
$| = 1;
34
34
35
my $DEBUG = 0;
36
my $data  = CGI->new;
35
my $data  = CGI->new;
37
my $imagenumber;
36
my $imagenumber;
38
37
Lines 72-79 if ( C4::Context->preference("OPACLocalCoverImages") ) { Link Here
72
        my $cover_images = $biblio->cover_images;
71
        my $cover_images = $biblio->cover_images;
73
        if ( $cover_images->count ) {
72
        if ( $cover_images->count ) {
74
            $image = $cover_images->next;
73
            $image = $cover_images->next;
75
        } else {
76
            warn "No images for this biblio" if $DEBUG;
77
        }
74
        }
78
    }
75
    }
79
}
76
}
(-)a/opac/opac-search.pl (-1 lines)
Lines 632-638 if ($tag) { Link Here
632
    my $taglist = get_tags({term=>$tag, approved=>1});
632
    my $taglist = get_tags({term=>$tag, approved=>1});
633
    $results_hashref->{biblioserver}->{hits} = scalar (@$taglist);
633
    $results_hashref->{biblioserver}->{hits} = scalar (@$taglist);
634
    my @marclist = map { C4::Biblio::GetXmlBiblio( $_->{biblionumber} ) } @$taglist;
634
    my @marclist = map { C4::Biblio::GetXmlBiblio( $_->{biblionumber} ) } @$taglist;
635
    $DEBUG and printf STDERR "taglist (%s biblionumber)\nmarclist (%s records)\n", scalar(@$taglist), scalar(@marclist);
636
    $results_hashref->{biblioserver}->{RECORDS} = \@marclist;
635
    $results_hashref->{biblioserver}->{RECORDS} = \@marclist;
637
    # FIXME: tag search and standard search should work together, not exclusively
636
    # FIXME: tag search and standard search should work together, not exclusively
638
    # FIXME: Because search and standard search don't work together OpacHiddenItems
637
    # FIXME: Because search and standard search don't work together OpacHiddenItems
(-)a/patroncards/edit-batch.pl (-1 lines)
Lines 20-26 Link Here
20
20
21
21
22
use Modern::Perl;
22
use Modern::Perl;
23
use vars qw($debug);
24
23
25
use CGI qw ( -utf8 );
24
use CGI qw ( -utf8 );
26
use autouse 'Data::Dumper' => qw(Dumper);
25
use autouse 'Data::Dumper' => qw(Dumper);
(-)a/patroncards/manage.pl (-1 lines)
Lines 19-25 Link Here
19
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
# along with Koha; if not, see <http://www.gnu.org/licenses>.
20
20
21
use Modern::Perl;
21
use Modern::Perl;
22
use vars qw($debug);
23
22
24
use CGI qw ( -utf8 );
23
use CGI qw ( -utf8 );
25
use autouse 'Data::Dumper' => qw(Dumper);
24
use autouse 'Data::Dumper' => qw(Dumper);
(-)a/t/Auth.t (-5 / +1 lines)
Lines 16-22 Link Here
16
# along with Koha; if not, see <http://www.gnu.org/licenses>.
16
# along with Koha; if not, see <http://www.gnu.org/licenses>.
17
17
18
use Modern::Perl;
18
use Modern::Perl;
19
use Test::More tests => 13;
19
use Test::More tests => 12;
20
use Test::Warn;
20
use Test::Warn;
21
21
22
use C4::Auth qw / in_iprange /;
22
use C4::Auth qw / in_iprange /;
Lines 35-41 ok(!in_iprange("127.0.0.1 8.8.8.8 192.168.2.1/24 192.168.3.1/24 192.168.1.1-192. Link Here
35
ok(in_iprange(""), "blank list given, no preference set - implies everything goes through.");
35
ok(in_iprange(""), "blank list given, no preference set - implies everything goes through.");
36
ok(in_iprange(), "no list given, no preference set - implies everything goes through.");
36
ok(in_iprange(), "no list given, no preference set - implies everything goes through.");
37
ok(in_iprange("192.168.1.1/36"), 'simple invalid ip range/36 with remote ip in it');
37
ok(in_iprange("192.168.1.1/36"), 'simple invalid ip range/36 with remote ip in it');
38
$ENV{DEBUG} = 1;
39
warning_like { in_iprange("192.168.1.1/36") }
40
    qr/cidrlookup failed for/,
41
    'noisy simple invalid ip range/36 with remote ip in it';
(-)a/t/db_dependent/00-strict.t (-3 lines)
Lines 44-52 if ( $ENV{KOHA_PROVE_CPUS} ) { Link Here
44
    $ncpu = Sys::CPU::cpu_count();
44
    $ncpu = Sys::CPU::cpu_count();
45
}
45
}
46
46
47
print "Using $ncpu CPUs...\n"
48
    if $ENV{DEBUG};
49
50
my $pm   = Parallel::ForkManager->new($ncpu);
47
my $pm   = Parallel::ForkManager->new($ncpu);
51
48
52
foreach my $d (@dirs) {
49
foreach my $d (@dirs) {
(-)a/t/db_dependent/Circulation/dateexpiry.t (-2 lines)
Lines 32-39 $schema->storage->txn_begin; Link Here
32
32
33
my $builder = t::lib::TestBuilder->new();
33
my $builder = t::lib::TestBuilder->new();
34
34
35
$ENV{ DEBUG } = 0;
36
37
my $patron_category = $builder->build({ source => 'Category', value => { category_type => 'P', enrolmentfee => 0 } });
35
my $patron_category = $builder->build({ source => 'Category', value => { category_type => 'P', enrolmentfee => 0 } });
38
36
39
subtest 'Tests for CanBookBeIssued related to dateexpiry' => sub {
37
subtest 'Tests for CanBookBeIssued related to dateexpiry' => sub {
(-)a/t/db_dependent/Context.t (-3 / +1 lines)
Lines 4-16 use Modern::Perl; Link Here
4
4
5
use Test::More;
5
use Test::More;
6
use Test::MockModule;
6
use Test::MockModule;
7
use vars qw($debug $koha $dbh $config $ret);
7
use vars qw($koha $dbh $config $ret);
8
use t::lib::Mocks;
8
use t::lib::Mocks;
9
9
10
use Koha::Database;
10
use Koha::Database;
11
11
12
BEGIN {
12
BEGIN {
13
    $debug = $ENV{DEBUG} || 0;
14
13
15
    # Note: The overall number of tests may vary by configuration.
14
    # Note: The overall number of tests may vary by configuration.
16
    # First we need to check your environmental variables
15
    # First we need to check your environmental variables
Lines 55-61 my @keys = keys %$koha; Link Here
55
my $width = 0;
54
my $width = 0;
56
if (ok(@keys)) { 
55
if (ok(@keys)) { 
57
    $width = (sort {$a <=> $b} map {length} @keys)[-1];
56
    $width = (sort {$a <=> $b} map {length} @keys)[-1];
58
    $debug and diag "widest key is $width";
59
}
57
}
60
foreach (sort @keys) {
58
foreach (sort @keys) {
61
	ok(exists $koha->{$_}, 
59
	ok(exists $koha->{$_}, 
(-)a/tools/scheduler.pl (-9 lines)
Lines 26-37 use CGI qw ( -utf8 ); Link Here
26
use C4::Output;
26
use C4::Output;
27
use Koha::DateUtils;;
27
use Koha::DateUtils;;
28
28
29
use vars qw($debug);
30
31
BEGIN {
32
    $debug = $ENV{DEBUG} || 0;
33
}
34
35
my $input = CGI->new;
29
my $input = CGI->new;
36
my $base;
30
my $base;
37
31
Lines 115-121 $template->param( 'savedreports' => $reports ); Link Here
115
$template->param( JOBS           => \@jobloop );
109
$template->param( JOBS           => \@jobloop );
116
my $time = localtime(time);
110
my $time = localtime(time);
117
$template->param( 'time' => $time );
111
$template->param( 'time' => $time );
118
$template->param(
119
    debug                    => $debug,
120
);
121
output_html_with_http_headers $input, $cookie, $template->output;
112
output_html_with_http_headers $input, $cookie, $template->output;
(-)a/tools/upload-cover-image.pl (-4 lines)
Lines 51-58 use Koha::Items; Link Here
51
use Koha::UploadedFiles;
51
use Koha::UploadedFiles;
52
use C4::Log;
52
use C4::Log;
53
53
54
my $debug = 1;
55
56
my $input = CGI->new;
54
my $input = CGI->new;
57
55
58
my $fileID = $input->param('uploadedfileid');
56
my $fileID = $input->param('uploadedfileid');
Lines 161-167 if ($fileID) { Link Here
161
                          : ( $line =~ /,/ )  ? ","
159
                          : ( $line =~ /,/ )  ? ","
162
                          :                     "";
160
                          :                     "";
163
161
164
                        #$debug and warn "Delimeter is \'$delim\'";
165
                        unless ( $delim eq "," || $delim eq "\t" ) {
162
                        unless ( $delim eq "," || $delim eq "\t" ) {
166
                            warn
163
                            warn
167
"Unrecognized or missing field delimeter. Please verify that you are using either a ',' or a 'tab'";
164
"Unrecognized or missing field delimeter. Please verify that you are using either a ',' or a 'tab'";
168
- 

Return to bug 28606