Attachment #122330 for bug #28606

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




use C4::Languages;
use C4::Search::History;
use Koha;
use Koha::Logger;
use Koha::Caches;
use Koha::AuthUtils qw(get_script_name hash_password);
use Koha::Checkouts;

use C4::Log qw/logaction/;

# use utf8;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $ldap $cas $caslogout);

BEGIN {
    sub psgi_env { any { /^psgi\./ } keys %ENV }


    C4::Context->set_remote_address;

    $debug     = $ENV{DEBUG};
    @ISA       = qw(Exporter);
    @EXPORT    = qw(&checkauth &get_template_and_user &haspermission &get_user_subpermissions);
    @EXPORT_OK = qw(&check_api_auth &get_session &check_cookie_auth &checkpw &checkpw_internal &checkpw_hash


    # remove the 3 last . to have a Perl number
    $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
    Koha::Logger->get->debug("kohaversion : $kohaversion");
    if ( $version < $kohaversion ) {
        my $warning = "Database update needed, redirecting to %s. Database is $version and Koha is $kohaversion";
        if ( $type ne 'opac' ) {


sub checkauth {
    my $query = shift;
    $debug and warn "Checking Auth";

    # Get shibboleth login attribute
    my $shib = C4::Context->config('useshibboleth') && shib_ok();

                $session->param('desk_id'),      $session->param('desk_name'),
                $session->param('register_id'),  $session->param('register_name')
            );
            Koha::Logger->get->debug(sprintf "AUTH_SESSION: (%s)\t%s %s - %s", map { $session->param($_) } qw(cardnumber firstname surname branch));
            $ip          = $session->param('ip');
            $lasttime    = $session->param('lasttime');
            $userid      = $s_userid;


            #if a user enters an id ne to the id in the current session, we need to log them in...
            #first we need to clear the anonymous session...
            $debug and warn "query id = $q_userid but session id = $s_userid";
            $anon_search_history = $session->param('search_history');
            $session->delete();
            $session->flush;

                    my $sth = $dbh->prepare("$select where userid=?");
                    $sth->execute($userid);
                    unless ( $sth->rows ) {
                        $debug and print STDERR "AUTH_1: no rows for userid='$userid'\n";
                        $sth = $dbh->prepare("$select where cardnumber=?");
                        $sth->execute($cardnumber);

                        unless ( $sth->rows ) {
                            $debug and print STDERR "AUTH_2a: no rows for cardnumber='$cardnumber'\n";
                            $sth->execute($userid);
                            unless ( $sth->rows ) {
                                $debug and print STDERR "AUTH_2b: no rows for userid='$userid' AS cardnumber\n";
                            }
                        }
                    }
                    if ( $sth->rows ) {
                        ( $borrowernumber, $firstname, $surname, $userflags,
                            $branchcode, $branchname, $emailaddress ) = $sth->fetchrow;
                        $debug and print STDERR "AUTH_3 results: " .
                          "$cardnumber,$borrowernumber,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress\n";
                    } else {
                        print STDERR "AUTH_3: no results for userid='$userid', cardnumber='$cardnumber'.\n";
                    }

                    # launch a sequence to check if we have a ip for the branch, i

                    $session->param( 'shibboleth',   $shibSuccess );
                    $session->param( 'register_id',  $register_id );
                    $session->param( 'register_name',  $register_name );
                    $debug and printf STDERR "AUTH_4: (%s)\t%s %s - %s\n", map { $session->param($_) } qw(cardnumber firstname surname branch);
                }
                $session->param('cas_ticket', $cas_ticket) if $cas_ticket;
                C4::Context->set_userenv(

            # $return: 0 = invalid user
            # reset to anonymous session
            else {
                $debug and warn "Login failed, resetting anonymous session...";
                if ($userid) {
                    $info{'invalid_username_or_password'} = 1;
                    C4::Context->_unset_userenv($sessionID);

        }    # END if ( $q_userid
        elsif ( $type eq "opac" ) {

            # if we are here this is an anonymous session; add public lists to it and a few other items...
            # anonymous sessions are created only for the OPAC
            $debug and warn "Initiating an anonymous session...";

            # setting a couple of other session vars...
            $session->param( 'ip',          $session->remote_addr() );

        # Proxy CAS auth
        if ( $cas && $query->param('PT') ) {
            my $retuserid;
            $debug and print STDERR "## check_api_auth - checking CAS\n";

            # In case of a CAS authentication, we use the ticket instead of the password
            my $PT = $query->param('PT');

    if ( $patron and $patron->account_locked ) {
        # Nothing to check, account is locked
    } elsif ($ldap && defined($password)) {
        $debug and print STDERR "## checkpw - checking LDAP\n";
        my ( $retval, $retcard, $retuserid ) = checkpw_ldap(@_);    # EXTERNAL AUTH
        if ( $retval == 1 ) {
            @return = ( $retval, $retcard, $retuserid );

        $check_internal_as_fallback = 1 if $retval == 0;

    } elsif ( $cas && $query && $query->param('ticket') ) {
        $debug and print STDERR "## checkpw - checking CAS\n";

        # In case of a CAS authentication, we use the ticket instead of the password
        my $ticket = $query->param('ticket');

    # time around.
    elsif ( $shib && $shib_login && !$password ) {

        $debug and print STDERR "## checkpw - checking Shibboleth\n";

        # In case of a Shibboleth authentication, we expect a shibboleth user attribute
        # (defined under shibboleth mapping in koha-conf.xml) to contain the login of the
        # shibboleth-authenticated user

    if (scalar @allowedipranges > 0) {
        my @rangelist;
        eval { @rangelist = Net::CIDR::range2cidr(@allowedipranges); }; return 0 if $@;
        eval { $result = Net::CIDR::cidrlookup($ENV{'REMOTE_ADDR'}, @rangelist) } || Koha::Logger->get->warn('cidrlookup failed for ' . join(' ',@rangelist) );
     }
     return $result ? 1 : 0;
}




use FindBin;
use YAML::XS;

use Koha::Logger;

use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

BEGIN {
    require Exporter;
    $debug = $ENV{DEBUG};
    @ISA   = qw(Exporter);
    @EXPORT = qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url logout_if_required);
}

# Checks for password correctness
# In our case : is there a ticket, is it valid and does it match one of our users ?
sub checkpw_cas {
    $debug and warn "checkpw_cas";
    my ($dbh, $ticket, $query, $type) = @_;
    my $retnumber;
    my ( $cas, $uri ) = _get_cas_and_service($query, undef, $type);

    # If we got a ticket
    if ($ticket) {
        $debug and warn "Got ticket : $ticket";

        # We try to validate it
        my $val = $cas->service_validate($uri, $ticket );

        if ( $val->is_success() ) {

            my $userid = $val->user();
            $debug and warn "User CAS authenticated as: $userid";

            # 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


            }

            # If we reach this point, then the user is a valid CAS user, but not a Koha user
            Koha::Logger->get->info("User $userid is not a valid Koha user");

        } else {
            my $logger = Koha::Logger->get;
            $logger->debug("Problem when validating ticket : $ticket");
            $logger->debug("Authen::CAS::Client::Response::Error: " . $val->error()) if $val->is_error();
            $logger->debug("Authen::CAS::Client::Response::Failure: " . $val->message()) if $val->is_failure();
            $logger->debug(Data::Dumper::Dumper($@)) if $val->is_error() or $val->is_failure();
            return 0;
        }
    }


# Proxy CAS auth
sub check_api_auth_cas {
    $debug and warn "check_api_auth_cas";
    my ($dbh, $PT, $query, $type) = @_;
    my $retnumber;
    my ( $cas, $uri ) = _get_cas_and_service($query, undef, $type);

        if ( $r->is_success ) {

            # We've got a username !
            $debug and warn "User authenticated as: ", $r->user, "\n";
            $debug and warn "Proxied through:\n";
            $debug and warn "  $_\n" for $r->proxies;

            my $userid = $r->user;

            # 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

            }

            # If we reach this point, then the user is a valid CAS user, but not a Koha user
            Koha::Logger->get->info("User $userid is not a valid Koha user");

        } else {
            Koha::Logger->get->debug("Proxy Ticket authentication failed");
            return 0;
        }
    }




use Net::LDAP;
use Net::LDAP::Filter;

use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

BEGIN {
	require Exporter;

$ldappassword = $ldap->{pass}		;
our %mapping  = %{$ldap->{mapping}}; # FIXME dpavlin -- don't die because of || (); from 6eaf8511c70eb82d797c941ef528f4310a15e9f9
my @mapkeys = keys %mapping;
#warn "Got ", scalar(@mapkeys), " ldap mapkeys (  total  ): ", join ' ', @mapkeys, "\n";
@mapkeys = grep {defined $mapping{$_}->{is}} @mapkeys;
#warn "Got ", scalar(@mapkeys), " ldap mapkeys (populated): ", join ' ', @mapkeys, "\n";

my %categorycode_conversions;
my $default_categorycode;

        return 0;
    }

	#$debug and $db->debug(5);
    my $userldapentry;

    # first, LDAP authentication

    if (( $borrowernumber and $config{update}   ) or
        (!$borrowernumber and $config{replicate})   ) {
        %borrower = ldap_entry_2_hash($userldapentry,$userid);
        #warn "checkpw_ldap received \%borrower w/ " . keys(%borrower), " keys: ", join(' ', keys %borrower), "\n";
    }

    if ($borrowernumber) {

	my %borrower = ( cardnumber => shift );
	my %memberhash;
	$userldapentry->exists('uid');	# This is bad, but required!  By side-effect, this initializes the attrs hash. 
    #foreach (keys %$userldapentry) {
    #    print STDERR "\n\nLDAP key: $_\t", sprintf('(%s)', ref $userldapentry->{$_}), "\n";
    #}
		}
	}
	my $x = $userldapentry->{attrs} or return;
	foreach (keys %$x) {
		$memberhash{$_} = join ' ', @{$x->{$_}};	
        #warn sprintf("building \$memberhash{%s} = ", $_, join(' ', @{$x->{$_}})), "\n";
	}
    warn #"Finished \%memberhash has ", scalar(keys %memberhash), " keys\n",
					"Referencing \%mapping with ", scalar(keys %mapping), " keys\n";
	foreach my $key (keys %mapping) {
		my  $data = $memberhash{ lc($mapping{$key}->{is}) }; # Net::LDAP returns all names in lowercase
        #warn "mapping %20s ==> %-20s (%s)\n", $key, $mapping{$key}->{is}, $data;
		unless (defined $data) { 
            $data = $mapping{$key}->{content} || undef;
		}

	$sth->execute( uc($borrower{'categorycode'}) );
	unless ( my $row = $sth->fetchrow_hashref ) {
		my $default = $mapping{'categorycode'}->{content};
        #warn "Can't find ", $borrower{'categorycode'}, " default to: $default for ", $borrower{userid};
		$borrower{'categorycode'} = $default
	}



	my $sth = $dbh->prepare("$select WHERE userid=?");	# was cardnumber=?
	$sth->execute($arg);
    #warn "Userid '$arg' exists_local? %s\n", $sth->rows;
	($sth->rows == 1) and return $sth->fetchrow;

	$sth = $dbh->prepare("$select WHERE cardnumber=?");
	$sth->execute($arg);
    #warn "Cardnumber '$arg' exists_local? %s\n", $sth->rows;
	($sth->rows == 1) and return $sth->fetchrow;
	return 0;
}

    }

    my $digest = hash_password($password);
    #warn "changing local password for borrowernumber=$borrowerid to '$digest'\n";
    Koha::Patrons->find($borrowerid)->set_password({ password => $password, skip_validation => 1 });

    my ($ok, $cardnum) = checkpw_internal(C4::Context->dbh, $userid, $password);

        while ( my $attribute_type = $attribute_types->next ) {
           my $code = $attribute_type->code;
           @keys = grep { $_ ne $code } @keys;
           #warn "ignoring extended patron attribute '%s' in update_local()\n", $code;
        }
    }


        join(',', map {"$_=?"} @keys) .
        "\nWHERE   borrowernumber=? ";
    my $sth = $dbh->prepare($query);
    #warn $query, "\n", join "\n", map {"$_ = '" . $borrower->{$_} . "'"} @keys;
    #warn "\nuserid = $userid\n";
            join "\n", map {"$_ = '" . $borrower->{$_} . "'"} @keys;
        print STDERR "\nuserid = $userid\n";
    }
    $sth->execute(
        ((map {$borrower->{$_}} @keys), $borrowerid)
    );

Lines 28-38 use Carp; Link Here

(-)a/C4/Auth_with_shibboleth.pm (-30 / +17 lines)
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 {




use Koha::Course::Items;
use Koha::Course::Reserves;

use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS @FIELDS);

BEGIN {
    require Exporter;

    );
    %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );

    $DEBUG = 0;
    @FIELDS = ( 'itype', 'ccode', 'homebranch', 'holdingbranch', 'location' );
}



sub GetCourse {
    my ($course_id) = @_;
    warn whoami() . "( $course_id )" if $DEBUG;

    my $course = Koha::Courses->find( $course_id );
    return unless $course;


sub ModCourse {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $dbh = C4::Context->dbh;



sub GetCourses {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my @query_keys;
    my @query_values;


sub EnableOrDisableCourseItems {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $course_id = $params{'course_id'};
    my $enabled = $params{'enabled'} || 0;


sub EnableOrDisableCourseItem {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $ci_id   = $params{'ci_id'};



sub GetCourseInstructors {
    my ($course_id) = @_;
    warn "C4::CourseReserves::GetCourseInstructors( $course_id )"
      if $DEBUG;

    my $query = "
        SELECT * FROM borrowers


sub ModCourseInstructors {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $course_id       = $params{'course_id'};
    my $mode            = $params{'mode'};


sub GetCourseItem {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $ci_id      = $params{'ci_id'};
    my $itemnumber = $params{'itemnumber'};


sub ModCourseItem {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $itemnumber = $params{'itemnumber'};



sub _AddCourseItem {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    $params{homebranch} ||= undef; # Can't be empty string, FK constraint
    $params{holdingbranch} ||= undef; # Can't be empty string, FK constraint


sub _UpdateCourseItem {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $ci_id         = $params{'ci_id'};
    my $course_item   = $params{'course_item'};


sub _RevertFields {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $ci_id = $params{'ci_id'};



sub _SwapAllFields {
    my ( $ci_id, $enabled ) = @_;
    warn "C4::CourseReserves::_SwapFields( $ci_id )" if $DEBUG;

    my $course_item = Koha::Course::Items->find( $ci_id );
    my $item = Koha::Items->find( $course_item->itemnumber );


sub GetCourseItems {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $course_id  = $params{'course_id'};
    my $itemnumber = $params{'itemnumber'};


sub DelCourseItem {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $ci_id = $params{'ci_id'};



sub GetCourseReserve {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $cr_id     = $params{'cr_id'};
    my $course_id = $params{'course_id'};


sub ModCourseReserve {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $course_id   = $params{'course_id'};
    my $ci_id       = $params{'ci_id'};


sub GetCourseReserves {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $course_id       = $params{'course_id'};
    my $ci_id           = $params{'ci_id'};


sub DelCourseReserve {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $cr_id = $params{'cr_id'};



sub GetItemCourseReservesInfo {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $itemnumber = $params{'itemnumber'};



sub CountCourseReservesForItem {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $ci_id      = $params{'ci_id'};
    my $itemnumber = $params{'itemnumber'};


sub SearchCourses {
    my (%params) = @_;
    warn identify_myself(%params) if $DEBUG;

    my $term = $params{'term'};


    return "( $string )";
}

sub identify_myself {
    my (%params) = @_;

    return whowasi() . stringify_params(%params);
}

1;

=head1 AUTHOR




use Business::ISBN;
use Business::ISSN;
use autouse 'Data::cselectall_arrayref' => qw(Dumper);
use vars qw(@ISA @EXPORT @EXPORT_OK);

BEGIN {
	require Exporter;

        &GetVariationsOfISSNs
        &NormalizeISSN

		$DEBUG
	);
	$DEBUG = 0;
}

=head1 NAME

    my @imagesets = (); # list of hasrefs of image set data to pass to template
    my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
    foreach my $imagesubdir ( @subdirectories ) {
    warn $imagesubdir if $DEBUG;
        my @imagelist     = (); # hashrefs of image info
        my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
        my $imagesetactive = 0;

Lines 28-34 use List::MoreUtils qw( any ); Link Here

(-)a/C4/Languages.pm (-2 / +1 lines)
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





use vars qw(@ISA @EXPORT);

use constant DEBUG => 0;

BEGIN {
    @ISA = qw(Exporter);
    @EXPORT = qw(


sub GetModificationTemplates {
  my ( $template_id ) = @_;
  warn("C4::MarcModificationTemplates::GetModificationTemplates( $template_id )") if DEBUG;

  my $dbh = C4::Context->dbh;
  my $sth = $dbh->prepare("SELECT * FROM marc_modification_templates ORDER BY name");

sub GetModificationTemplateActions {
  my ( $template_id ) = @_;

  warn( "C4::MarcModificationTemplates::GetModificationTemplateActions( $template_id )" ) if DEBUG;

  my $dbh = C4::Context->dbh;
  my $sth = $dbh->prepare("SELECT * FROM marc_modification_template_actions WHERE template_id = ? ORDER BY ordering");
  $sth->execute( $template_id );

    push( @actions, $action );
  }

  warn( Data::Dumper::Dumper( @actions ) ) if DEBUG > 4;

  return @actions;
}


    $description
  ) = @_;

  warn( "C4::MarcModificationTemplates::AddModificationTemplateAction( $template_id, $action,
                    $field_number, $from_field, $from_subfield, $field_value, $to_field, $to_subfield,
                    $to_regex_search, $to_regex_replace, $to_regex_modifiers, $conditional, $conditional_field, $conditional_subfield, $conditional_comparison,
                    $conditional_value, $conditional_regex, $description )" ) if DEBUG;

  $conditional ||= undef;
  $conditional_comparison ||= undef;
  $conditional_regex ||= '0';


sub ModifyRecordsWithTemplate {
  my ( $template_id, $batch ) = @_;
  warn( "C4::MarcModificationTemplates::ModifyRecordsWithTemplate( $template_id, $batch )" ) if DEBUG;

  while ( my $record = $batch->next() ) {
    ModifyRecordWithTemplate( $template_id, $record );


sub ModifyRecordWithTemplate {
    my ( $template_id, $record ) = @_;
    warn( "C4::MarcModificationTemplates::ModifyRecordWithTemplate( $template_id, $record )" ) if DEBUG;
    warn( "Unmodified Record:\n" . $record->as_formatted() ) if DEBUG >= 10;

    my $current_date = dt_from_string()->ymd();
    my $branchcode = '';

                });
            }
        }

        warn( $record->as_formatted() ) if DEBUG >= 10;
    }

    return;




use Koha::Patrons;
use Koha::Patron::Categories;

our (@ISA,@EXPORT,@EXPORT_OK);

BEGIN {
    $debug = $ENV{DEBUG} || 0;
    require Exporter;
    @ISA = qw(Exporter);
    #Get data

        push( @query_params, $anonymous_patron );
    }

    warn $query if $debug;

    my $sth = $dbh->prepare($query);
    if (scalar(@query_params)>0){
        $sth->execute(@query_params);

Lines 26-35 use Modern::Perl; Link Here

(-)a/C4/Members/Statistics.pm (-2 / +1 lines)
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

Lines 260-266 sub draw_text { Link Here

(-)a/C4/Patroncards/Patroncard.pm (-1 lines)
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$//;




use C4::SIP::ILS::Transaction::Renew;
use C4::SIP::ILS::Transaction::RenewAll;

my $debug = 0;

my %supports = (
    'magnetic media'        => 1,
    'security inhibit'      => 0,

    my ($class, $institution) = @_;
    my $type = ref($class) || $class;
    my $self = {};
	$debug and warn "new ILS: INSTITUTION: " . Dumper($institution);
    siplog("LOG_DEBUG", "new ILS '%s'", $institution->{id});
    $self->{institution} = $institution;
    return bless $self, $type;


sub find_patron {
    my $self = shift;
 	$debug and warn "ILS: finding patron";
    return C4::SIP::ILS::Patron->new(@_);
}

sub find_item {
    my $self = shift;
	$debug and warn "ILS: finding item";
    return C4::SIP::ILS::Item->new(@_);
}


    else {
        $circ->do_checkout($account);
        if ( $circ->ok ) {
            $debug and warn "circ is ok";

            # If the item is already associated with this patron, then
            # we're renewing it.

Lines 25-32 use Koha::Account::Lines; Link Here

(-)a/C4/SIP/ILS/Transaction/FeePayment.pm (-2 lines)
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 {





our @ISA = qw(Exporter);
our @EXPORT_OK = qw(checksum verify_cksum);
our $debug = 0;

sub checksum {
    my $pkt = shift;

    my $cksum;
    my $shortsum;

    unless ($pkt =~ /AZ(....)$/) {
		$debug and warn "verify_cksum: sum ($1) detected";
	} else {
		warn "verify_cksum: no sum detected";
		return 0; # No checksum at end
	}




use C4::Output::JSONStream;
use JSON;

our $debug;

BEGIN {
    $debug = $ENV{DEBUG} || 0;
}

our ( $query, $cookie );

sub _output {

            next ROUTE if ( !defined( $query->param ( $param ) ) );
        }

        $debug and warn "Using $path";
        $handler->( @match );
        return;
    }





    my $subnamespace = $params->{subnamespace} // '';

    $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";

    $self->{'timeout'}   ||= 0;
    # Should we continue to support MEMCACHED ENV vars?
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE};

        $self->{'cache'} = $self->{'memcached_cache'};
    }

    $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');

    return
      bless $self,
      $class;


    return unless @servers;

    $ENV{DEBUG}
      && carp "Memcached server settings: "
      . join( ', ', @servers )
      . " with "
      . $self->{'namespace'};
    # Cache::Memcached::Fast::Safe doesn't allow a default expire time to be set
    # so we force it on setting.
    my $memcached = Cache::Memcached::Fast::Safe->new(


    my $cache = $options->{cache} || 'cache';
    croak "No key" unless $key;
    $ENV{DEBUG} && carp "set_in_cache for $key";

    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
    my $expiry = $options->{expiry};

    my $unsafe = $options->{unsafe} || 0;
    $key =~ s/[\x00-\x20]/_/g;
    croak "No key" unless $key;
    $ENV{DEBUG} && carp "get_from_cache for $key";
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );

    # Return L1 cache value if exists

Lines 81-90 sub TIESCALAR { Link Here

(-)a/Koha/Cache/Object.pm (-4 lines)
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'} ) )

Lines 42-49 our @EXPORT = qw( Link Here

(-)a/Koha/SimpleMARC.pm (-2 lines)
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.

Lines 66-73 Koha::XSLT::Base - Facilitate use of XSLT transformations Link Here

(-)a/Koha/XSLT/Base.pm (-2 / +1 lines)
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

Lines 502-509 $template->param( Link Here

(-)a/catalogue/detail.pl (-2 lines)
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") ) {

Lines 33-39 use Koha::Exceptions; Link Here

(-)a/catalogue/image.pl (-3 lines)
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	}

Lines 29-36 use Koha::DateUtils; Link Here

(-)a/cataloguing/value_builder/barcode.pl (-3 lines)
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>\|;

Lines 27-34 use C4::Barcodes::ValueBuilder; Link Here

(-)a/cataloguing/value_builder/barcode_manual.pl (-3 lines)
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>\|;




use C4::Auth qw/:DEFAULT get_session/;
use C4::Reserves;

use vars qw($debug);

BEGIN {
    $debug = $ENV{DEBUG} || 0;
}

my $input = CGI->new;
my $sessionID = $input->cookie("CGISESSID");
my $session = get_session($sessionID);

        query           => $input,
        type            => "intranet",
        flagsrequired   => { circulate => "circulate_remaining_permissions" },
        debug           => $debug,
    }
);





use C4::Auth qw/:DEFAULT get_session/;
use C4::Circulation;

use vars qw($debug);

BEGIN {
    $debug = $ENV{DEBUG} || 0;
}

my $input = CGI->new;
my $sessionID = $input->cookie("CGISESSID");
my $session = get_session($sessionID);

        query           => $input,
        type            => "intranet",
        flagsrequired   => { circulate => "circulate_remaining_permissions" },
        debug           => $debug,
    }
);


Lines 20-26 use ExtUtils::MakeMaker::Config; Link Here

(-)a/fix-perl-path.PL (-1 / +1 lines)
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

Lines 50-57 use File::Slurp; Link Here

(-)a/installer/data/mysql/updatedatabase.pl (-2 lines)
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,

Lines 817-826 Link Here

(-)a/koha-tmpl/opac-tmpl/bootstrap/en/modules/opac-shelves.tt (-4 lines)
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 %]

Lines 19-25 Link Here

(-)a/labels/label-edit-batch.pl (-1 lines)
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

Lines 20-27 Link Here

(-)a/labels/label-manage.pl (-2 lines)
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




use Email::Valid;
use Koha::SMS::Providers;

use vars qw($debug);

BEGIN {
	$debug = $ENV{DEBUG} || 0;
}
	
my $input = CGI->new;
($debug) or $debug = $input->param('debug') || 0;
my %data;

my $dbh = C4::Context->dbh;

           query => $input,
           type => "intranet",
           flagsrequired => {borrowers => 'edit_borrowers'},
           debug => ($debug) ? 1 : 0,
       });

my $borrowernumber = $input->param('borrowernumber');

        $newdata{'userid'} = $data{'userid'};
    }
}

$debug and warn join "\t", map {"$_: $newdata{$_}"} qw(dateofbirth dateenrolled dateexpiry);
my $extended_patron_attributes;
if ($op eq 'save' || $op eq 'insert'){


  
  if (C4::Context->preference("IndependentBranches")) {
    unless ( C4::Context->IsSuperLibrarian() ){
      $debug and print STDERR "  $newdata{'branchcode'} : ".$userenv->{flags}.":".$userenv->{branch};
      unless (!$newdata{'branchcode'} || $userenv->{branch} eq $newdata{'branchcode'}){
        push @errors, "ERROR_branch";
      }

###  Error checks should happen before this line.
$nok = $nok || scalar(@errors);
if ((!$nok) and $nodouble and ($op eq 'insert' or $op eq 'save')){
	$debug and warn "$op dates: " . join "\t", map {"$_: $newdata{$_}"} qw(dateofbirth dateenrolled dateexpiry);
    my $success;
	if ($op eq 'insert'){
		# we know it's not a duplicate borrowernumber or there would already be an error

}

$template->param( "show_guarantor" => ( $category_type =~ /A|I|S|X/ ) ? 0 : 1 ); # associate with step to know where you are
$debug and warn "memberentry step: $step";
$template->param(%data);
$template->param( "step_$step"  => 1) if $step;	# associate with step to know where u are
$template->param(  step  => $step   ) if $step;	# associate with step to know where u are




use Koha::Token;
use Koha::Checkouts;

use vars qw($debug);

BEGIN {
    $debug = $ENV{DEBUG} || 0;
}

my $input = CGI->new;
$debug or $debug = $input->param('debug') || 0;


my $print = $input->param('print');






$|=1;

my $DEBUG = 0;
my $query = CGI->new;
my $borrowernumber;


    $borrowernumber = shift;
}


warn "Borrowernumber passed in: $borrowernumber" if $DEBUG;

my $patron_image = Koha::Patron::Images->find($borrowernumber);

# NOTE: Never dump the contents of $imagedata->{'patronimage'} via a warn to a log or nasty




use C4::Koha;
use Koha::DateUtils;

#use Smart::Comments;
#use Data::Dumper;

use vars qw($debug);

BEGIN {
	$debug = $ENV{DEBUG} || 0;
}

my $input = CGI->new;
my $sessionID = $input->cookie("CGISESSID");
my $session = get_session($sessionID);

$debug or $debug = $input->param('debug') || 0;
my $print = $input->param('print');
my $error = $input->param('error');


Lines 59-65 my $delay; Link Here

(-)a/misc/cronjobs/staticfines.pl (-1 / +1 lines)
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(

Lines 38-44 GetOptions( Link Here

(-)a/misc/maintenance/UNIMARC_sync_date_created_with_marc_biblio.pl (-1 / +1 lines)
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 ?

Lines 30-36 if ( $#ARGV >= 3 && ! caller ) { # process command-line params only if not calle Link Here

(-)a/misc/migration_tools/koha-svc.pl (-1 / +1 lines)
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 ) {

Lines 37-44 use Koha::Items; Link Here

(-)a/offline_circ/enqueue_koc.pl (-2 lines)
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

Lines 266-272 sub kocIssueItem { Link Here

(-)a/offline_circ/process_koc.pl (-1 / +1 lines)
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,

Lines 32-38 use Koha::CoverImages; Link Here

(-)a/opac/opac-image.pl (-3 lines)
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	}

Lines 632-638 if ($tag) { Link Here

(-)a/opac/opac-search.pl (-1 lines)
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

Lines 20-26 Link Here

(-)a/patroncards/edit-batch.pl (-1 lines)
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);

Lines 19-25 Link Here

(-)a/patroncards/manage.pl (-1 lines)
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);

Lines 16-22 Link Here

(-)a/t/Auth.t (-5 / +1 lines)
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';

Lines 44-52 if ( $ENV{KOHA_PROVE_CPUS} ) { Link Here

(-)a/t/db_dependent/00-strict.t (-3 lines)
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) {

Lines 32-39 $schema->storage->txn_begin; Link Here

(-)a/t/db_dependent/Circulation/dateexpiry.t (-2 lines)
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 {





use Test::More;
use Test::MockModule;
use vars qw($koha $dbh $config $ret);
use t::lib::Mocks;

use Koha::Database;

BEGIN {
    $debug = $ENV{DEBUG} || 0;

    # Note: The overall number of tests may vary by configuration.
    # First we need to check your environmental variables

my $width = 0;
if (ok(@keys)) { 
    $width = (sort {$a <=> $b} map {length} @keys)[-1];
    $debug and diag "widest key is $width";
}
foreach (sort @keys) {
	ok(exists $koha->{$_}, 




use C4::Output;
use Koha::DateUtils;;

use vars qw($debug);

BEGIN {
    $debug = $ENV{DEBUG} || 0;
}

my $input = CGI->new;
my $base;


$template->param( JOBS           => \@jobloop );
my $time = localtime(time);
$template->param( 'time' => $time );
$template->param(
    debug                    => $debug,
);
output_html_with_http_headers $input, $cookie, $template->output;




use Koha::UploadedFiles;
use C4::Log;

my $debug = 1;

my $input = CGI->new;

my $fileID = $input->param('uploadedfileid');

                          : ( $line =~ /,/ )  ? ","
                          :                     "";

                        #$debug and warn "Delimeter is \'$delim\'";
                        unless ( $delim eq "," || $delim eq "\t" ) {
                            warn
"Unrecognized or missing field delimeter. Please verify that you are using either a ',' or a 'tab'";
- 

Return to bug 28606

Lines 32-37 use C4::Templates; # to get the template Link Here

(-)a/C4/Auth.pm (-25 / +5 lines)
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	}

Lines 27-38 use CGI qw ( -utf8 ); Link Here

(-)a/C4/Auth_with_cas.pm (-17 / +10 lines)
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	}

Lines 29-35 use List::MoreUtils qw( any ); Link Here

(-)a/C4/Auth_with_ldap.pm (-23 / +17 lines)
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",
279	"Referencing \%mapping with ", scalar(keys %mapping), " keys\n";	276	"Referencing \%mapping with ", scalar(keys %mapping), " keys\n";
280	foreach my $key (keys %mapping) {	277	foreach my $key (keys %mapping) {
281	my $data = $memberhash{ lc($mapping{$key}->{is}) }; # Net::LDAP returns all names in lowercase	278	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;	279	#warn "mapping %20s ==> %-20s (%s)\n", $key, $mapping{$key}->{is}, $data;
283	unless (defined $data) {	280	unless (defined $data) {
284	$data = $mapping{$key}->{content} \|\| undef;	281	$data = $mapping{$key}->{content} \|\| undef;
285	}	282	}
Lines 304-310 sub ldap_entry_2_hash { Link Here
304	$sth->execute( uc($borrower{'categorycode'}) );	301	$sth->execute( uc($borrower{'categorycode'}) );
305	unless ( my $row = $sth->fetchrow_hashref ) {	302	unless ( my $row = $sth->fetchrow_hashref ) {
306	my $default = $mapping{'categorycode'}->{content};	303	my $default = $mapping{'categorycode'}->{content};
307	$debug && warn "Can't find ", $borrower{'categorycode'}, " default to: $default for ", $borrower{userid};	304	#warn "Can't find ", $borrower{'categorycode'}, " default to: $default for ", $borrower{userid};
308	$borrower{'categorycode'} = $default	305	$borrower{'categorycode'} = $default
309	}	306	}
310		307
Lines 318-329 sub exists_local { Link Here
318		315
319	my $sth = $dbh->prepare("$select WHERE userid=?"); # was cardnumber=?	316	my $sth = $dbh->prepare("$select WHERE userid=?"); # was cardnumber=?
320	$sth->execute($arg);	317	$sth->execute($arg);
321	$debug and printf STDERR "Userid '$arg' exists_local? %s\n", $sth->rows;	318	#warn "Userid '$arg' exists_local? %s\n", $sth->rows;
322	($sth->rows == 1) and return $sth->fetchrow;	319	($sth->rows == 1) and return $sth->fetchrow;
323		320
324	$sth = $dbh->prepare("$select WHERE cardnumber=?");	321	$sth = $dbh->prepare("$select WHERE cardnumber=?");
325	$sth->execute($arg);	322	$sth->execute($arg);
326	$debug and printf STDERR "Cardnumber '$arg' exists_local? %s\n", $sth->rows;	323	#warn "Cardnumber '$arg' exists_local? %s\n", $sth->rows;
327	($sth->rows == 1) and return $sth->fetchrow;	324	($sth->rows == 1) and return $sth->fetchrow;
328	return 0;	325	return 0;
329	}	326	}
Lines 358-364 sub _do_changepassword { Link Here
358	}	355	}
359		356
360	my $digest = hash_password($password);	357	my $digest = hash_password($password);
361	$debug and print STDERR "changing local password for borrowernumber=$borrowerid to '$digest'\n";	358	#warn "changing local password for borrowernumber=$borrowerid to '$digest'\n";
362	Koha::Patrons->find($borrowerid)->set_password({ password => $password, skip_validation => 1 });	359	Koha::Patrons->find($borrowerid)->set_password({ password => $password, skip_validation => 1 });
363		360
364	my ($ok, $cardnum) = checkpw_internal(C4::Context->dbh, $userid, $password);	361	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 ) {	379	while ( my $attribute_type = $attribute_types->next ) {
383	my $code = $attribute_type->code;	380	my $code = $attribute_type->code;
384	@keys = grep { $_ ne $code } @keys;	381	@keys = grep { $_ ne $code } @keys;
385	$debug and printf STDERR "ignoring extended patron attribute '%s' in update_local()\n", $code;	382	#warn "ignoring extended patron attribute '%s' in update_local()\n", $code;
386	}	383	}
387	}	384	}
388		385
Lines 391-401 sub update_local { Link Here
391	join(',', map {"$_=?"} @keys) .	388	join(',', map {"$_=?"} @keys) .
392	"\nWHERE borrowernumber=? ";	389	"\nWHERE borrowernumber=? ";
393	my $sth = $dbh->prepare($query);	390	my $sth = $dbh->prepare($query);
394	if ($debug) {	391	#warn $query, "\n", join "\n", map {"$_ = '" . $borrower->{$_} . "'"} @keys;
395	print STDERR $query, "\n",	392	#warn "\nuserid = $userid\n";
396	join "\n", map {"$_ = '" . $borrower->{$_} . "'"} @keys;
397	print STDERR "\nuserid = $userid\n";
398	}
399	$sth->execute(	393	$sth->execute(
400	((map {$borrower->{$_}} @keys), $borrowerid)	394	((map {$borrower->{$_}} @keys), $borrowerid)
401	);	395	);

Lines 27-33 use Koha::Course::Instructors; Link Here

(-)a/C4/CourseReserves.pm (-31 / +1 lines)
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

Lines 30-36 use Koha::MarcSubfieldStructures; Link Here

(-)a/C4/Koha.pm (-4 / +1 lines)
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;

Lines 28-35 use Koha::DateUtils; Link Here

(-)a/C4/MarcModificationTemplates.pm (-17 lines)
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;

Lines 44-53 use Koha::List::Patron; Link Here

(-)a/C4/Members.pm (-4 / +1 lines)
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);

Lines 19-26 use C4::SIP::ILS::Transaction::Hold; Link Here

(-)a/C4/SIP/ILS.pm (-6 lines)
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.

Lines 6-12 use warnings; Link Here

(-)a/C4/SIP/Sip/Checksum.pm (-4 / +1 lines)
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	}

Lines 47-58 use C4::Output qw( :ajax ); Link Here

(-)a/C4/Service.pm (-7 lines)
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	}

Lines 73-80 sub new { Link Here

(-)a/Koha/Cache.pm (-11 lines)
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

Lines 25-36 use CGI qw ( -utf8 ); Link Here

(-)a/circ/hold-transfer-slip.pl (-7 lines)
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

Lines 26-37 use CGI qw ( -utf8 ); Link Here

(-)a/circ/transfer-slip.pl (-7 lines)
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

Lines 49-62 use Koha::Token; Link Here

(-)a/members/memberentry.pl (-13 / +1 lines)
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

Lines 44-58 use Koha::Patron::Files; Link Here

(-)a/members/moremember.pl (-8 lines)
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

Lines 30-36 use Koha::Patron::Images; Link Here

(-)a/members/patronimage.pl (-4 lines)
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

Lines 41-60 use C4::Members; Link Here

(-)a/members/printslip.pl (-10 lines)
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

Lines 4-16 use Modern::Perl; Link Here

(-)a/t/db_dependent/Context.t (-3 / +1 lines)
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->{$_},

Lines 26-37 use CGI qw ( -utf8 ); Link Here

(-)a/tools/scheduler.pl (-9 lines)
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;

Lines 51-58 use Koha::Items; Link Here

(-)a/tools/upload-cover-image.pl (-4 lines)
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	-