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 $debug $ldap $cas $caslogout);
+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/;
- $debug and print STDERR "kohaversion : $kohaversion\n";
+ 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')
);
- $debug and printf STDERR "AUTH_SESSION: (%s)\t%s %s - %s\n", map { $session->param($_) } qw(cardnumber firstname surname branch);
+ 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) } || ( $ENV{DEBUG} && warn 'cidrlookup failed for ' . join(' ',@rangelist) );
+ 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 $debug);
+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
- $debug and warn "User $userid is not a valid Koha user";
+ Koha::Logger->get->info("User $userid is not a valid Koha user");
} else {
- $debug and warn "Problem when validating ticket : $ticket";
- $debug and warn "Authen::CAS::Client::Response::Error: " . $val->error() if $val->is_error();
- $debug and warn "Authen::CAS::Client::Response::Failure: " . $val->message() if $val->is_failure();
- $debug and warn Data::Dumper::Dumper($@) if $val->is_error() or $val->is_failure();
+ 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
- $debug and warn "User $userid is not a valid Koha user";
+ Koha::Logger->get->info("User $userid is not a valid Koha user");
} else {
- $debug and warn "Proxy Ticket authentication failed";
+ 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 $debug);
+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;
-$debug and print STDERR "Got ", scalar(@mapkeys), " ldap mapkeys ( total ): ", join ' ', @mapkeys, "\n";
+#warn "Got ", scalar(@mapkeys), " ldap mapkeys ( total ): ", join ' ', @mapkeys, "\n";
@mapkeys = grep {defined $mapping{$_}->{is}} @mapkeys;
-$debug and print STDERR "Got ", scalar(@mapkeys), " ldap mapkeys (populated): ", join ' ', @mapkeys, "\n";
+#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);
- $debug and print STDERR "checkpw_ldap received \%borrower w/ " . keys(%borrower), " keys: ", join(' ', keys %borrower), "\n";
+ #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.
- if ($debug) {
- foreach (keys %$userldapentry) {
- print STDERR "\n\nLDAP key: $_\t", sprintf('(%s)', ref $userldapentry->{$_}), "\n";
- }
- }
+ #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->{$_}};
- $debug and print STDERR sprintf("building \$memberhash{%s} = ", $_, join(' ', @{$x->{$_}})), "\n";
+ #warn sprintf("building \$memberhash{%s} = ", $_, join(' ', @{$x->{$_}})), "\n";
}
- $debug and print STDERR "Finsihed \%memberhash has ", scalar(keys %memberhash), " keys\n",
- "Referencing \%mapping with ", scalar(keys %mapping), " keys\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
- $debug and printf STDERR "mapping %20s ==> %-20s (%s)\n", $key, $mapping{$key}->{is}, $data;
+ #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};
- $debug && warn "Can't find ", $borrower{'categorycode'}, " default to: $default for ", $borrower{userid};
+ #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);
- $debug and printf STDERR "Userid '$arg' exists_local? %s\n", $sth->rows;
+ #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);
- $debug and printf STDERR "Cardnumber '$arg' exists_local? %s\n", $sth->rows;
+ #warn "Cardnumber '$arg' exists_local? %s\n", $sth->rows;
($sth->rows == 1) and return $sth->fetchrow;
return 0;
}
}
my $digest = hash_password($password);
- $debug and print STDERR "changing local password for borrowernumber=$borrowerid to '$digest'\n";
+ #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;
- $debug and printf STDERR "ignoring extended patron attribute '%s' in update_local()\n", $code;
+ #warn "ignoring extended patron attribute '%s' in update_local()\n", $code;
}
}
join(',', map {"$_=?"} @keys) .
"\nWHERE borrowernumber=? ";
my $sth = $dbh->prepare($query);
- if ($debug) {
- print STDERR $query, "\n",
- join "\n", map {"$_ = '" . $borrower->{$_} . "'"} @keys;
- print STDERR "\nuserid = $userid\n";
- }
+ #warn $query, "\n", join "\n", map {"$_ = '" . $borrower->{$_} . "'"} @keys;
+ #warn "\nuserid = $userid\n";
$sth->execute(
((map {$borrower->{$_}} @keys), $borrowerid)
);
use CGI;
use List::MoreUtils qw(any);
-use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug);
+use Koha::Logger;
+
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
BEGIN {
require Exporter;
- $debug = $ENV{DEBUG};
@ISA = qw(Exporter);
@EXPORT =
qw(shib_ok logout_shib login_shib_url checkpw_shib get_login_shib);
my $matchAttribute = $config->{mapping}->{ $config->{matchpoint} }->{is};
if ( any { /(^psgi\.|^plack\.)/i } keys %ENV ) {
- $debug and warn $matchAttribute . " value: " . $ENV{"HTTP_".uc($matchAttribute)};
return $ENV{"HTTP_".uc($matchAttribute)} || '';
} else {
- $debug and warn $matchAttribute . " value: " . $ENV{$matchAttribute};
return $ENV{$matchAttribute} || '';
}
}
# Checks for password correctness
# In our case : does the given attribute match one of our users ?
sub checkpw_shib {
- $debug and warn "checkpw_shib";
my ( $match ) = @_;
my $config = _get_shib_config();
- $debug and warn "User Shibboleth-authenticated as: $match";
# Does the given shibboleth attribute value ($match) match a valid koha user ?
my $borrowers = Koha::Patrons->search( { $config->{matchpoint} => $match } );
if ( $borrowers->count > 1 ){
# If we have more than 1 borrower the matchpoint is not unique
# we cannot know which patron is the correct one, so we should fail
- $debug and warn "There are several users with $config->{matchpoint} of $match, matchpoints must be unique";
+ Koha::Logger->get->warn("There are several users with $config->{matchpoint} of $match, matchpoints must be unique");
return 0;
}
my $borrower = $borrowers->next;
return _autocreate( $config, $match );
} else {
# If we reach this point, the user is not a valid koha user
- $debug and warn "User with $config->{matchpoint} of $match is not a valid Koha user";
+ Koha::Logger->get->info("There are several users with $config->{matchpoint} of $match, matchpoints must be unique");
return 0;
}
}
my $protocol = "https://";
my $interface = C4::Context->interface;
- $debug and warn "shibboleth interface: " . $interface;
- my $uri;
- if ( $interface eq 'intranet' ) {
+ my $uri =
+ $interface eq 'intranet'
+ ? C4::Context->preference('staffClientBaseURL')
+ : C4::Context->preference('OPACBaseURL');
- $uri = C4::Context->preference('staffClientBaseURL') // '';
- if ($uri eq '') {
- $debug and warn 'staffClientBaseURL not set!';
- }
- } else {
- $uri = C4::Context->preference('OPACBaseURL') // '';
- if ($uri eq '') {
- $debug and warn 'OPACBaseURL not set!';
- }
- }
+ $uri or Koha::Logger->get->warn("Syspref staffClientBaseURL or OPACBaseURL not set!"); # FIXME We should die here
+
+ $uri ||= "";
if ($uri =~ /(.*):\/\/(.*)/) {
my $oldprotocol = $1;
if ($oldprotocol ne 'https') {
- $debug
- and warn
- 'Shibboleth requires OPACBaseURL/staffClientBaseURL to use the https protocol!';
+ Koha::Logger->get->warn('Shibboleth requires OPACBaseURL/staffClientBaseURL to use the https protocol!');
}
$uri = $2;
}
my $config = C4::Context->config('shibboleth');
if ( !$config ) {
- carp 'shibboleth config not defined' if $debug;
+ Koha::Logger->get->warn('shibboleth config not defined');
return 0;
}
if ( $config->{matchpoint}
&& defined( $config->{mapping}->{ $config->{matchpoint} }->{is} ) )
{
- if ($debug) {
- warn "koha borrower field to match: " . $config->{matchpoint};
- warn "shibboleth attribute to match: "
- . $config->{mapping}->{ $config->{matchpoint} }->{is};
- }
+ my $logger = Koha::Logger->get;
+ $logger->debug("koha borrower field to match: " . $config->{matchpoint});
+ $logger->debug("shibboleth attribute to match: " . $config->{mapping}->{ $config->{matchpoint} }->{is});
return $config;
}
else {
use Koha::Course::Items;
use Koha::Course::Reserves;
-use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG @FIELDS);
+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 $DEBUG);
+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;
use C4::Context;
use Koha::Caches;
use Koha::Cache::Memory::Lite;
-use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
BEGIN {
require Exporter;
&getAllLanguages
);
@EXPORT_OK = qw(getFrameworkLanguages getTranslatedLanguages getAllLanguages getLanguages get_bidi regex_lang_subtags language_get_description accept_language getlanguage);
- $DEBUG = 0;
}
=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,$debug);
+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);
use C4::Context;
-our ( @ISA, @EXPORT, @EXPORT_OK, $debug );
+our ( @ISA, @EXPORT, @EXPORT_OK );
BEGIN {
- $debug = $ENV{DEBUG} || 0;
require Exporter;
@ISA = qw(Exporter);
while (1) {
# $line =~ m/^.*(\s\b.*\b\s*|\s&|\<\b.*\b\>)$/; # original regexp... can be removed after dev stage is over
$line =~ m/^.*(\s.*\s*|\s&|\<.*\>)$/;
- 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;
$trim = $1 . $trim;
#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)
$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.
use parent qw(C4::SIP::ILS::Transaction);
-our $debug = 0;
-
my %fields = ();
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;
- if ($pkt =~ /AZ(....)$/) {
- $debug and warn "verify_cksum: sum ($1) detected";
- } else {
+ unless ($pkt =~ /AZ(....)$/) {
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
sub FETCH {
my ( $self, $index ) = @_;
- $ENV{DEBUG}
- && $index
- && carp "Retrieving cached hash member $index of $self->{'key'}";
-
my $now = time;
if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
);
-our $debug = 0;
-
=head1 NAME
SimpleMARC - Perl module for making simple MARC record alterations.
=head2 print_warns
- If set, print error messages to STDERR. False by default. Looks at the
- DEBUG environment variable too.
+ If set, print error messages to STDERR. False by default.
=head1 ERROR CODES
searchid => scalar $query->param('searchid'),
);
-# $debug and $template->param(debug_display => 1);
-
# Lists
if (C4::Context->preference("virtualshelves") ) {
$| = 1;
-my $DEBUG = 0;
my $data = CGI->new;
my $imagenumber;
my $cover_images = $biblio->cover_images;
if ( $cover_images->count ) {
$image = $cover_images->next;
- } else {
- warn "No images for this biblio" if $DEBUG;
}
}
}
use Algorithm::CheckDigits;
-my $DEBUG = 0;
-
my $builder = sub {
my ( $params ) = @_;
my $function_name = $params->{id};
my $nextnum;
my $scr;
my $autoBarcodeType = C4::Context->preference("autoBarcode");
- warn "Barcode type = $autoBarcodeType" if $DEBUG;
if ((not $autoBarcodeType) or $autoBarcodeType eq 'OFF') {
# don't return a value unless we have the appropriate syspref set
return q|<script></script>|;
use C4::Biblio qw/GetMarcFromKohaField/;
use Koha::DateUtils;
-my $DEBUG = 0;
-
my $builder = sub {
my ( $params ) = @_;
my $function_name = $params->{id};
my $nextnum;
my $scr;
my $autoBarcodeType = C4::Context->preference("autoBarcode");
- warn "Barcode type = $autoBarcodeType" if $DEBUG;
if ((not $autoBarcodeType) or $autoBarcodeType eq 'OFF') {
# don't return a value unless we have the appropriate syspref set
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,
}
);
use Tie::File;
my $basedir = (shift);
-my $DEBUG = exists $ENV{'DEBUG'} ? $ENV{'DEBUG'} : 0;
+my $DEBUG = 0;
$DEBUG = 1 if $basedir eq 'test';
# FIXME - The user might be installing a new database, so can't rely
# on /etc/koha.conf anyway.
-my $debug = 0;
-
my (
$sth,
$query,
<input type="hidden" name="format" id="download_format" value="" />
</form>
-<!-- DEBUG -->
- <div id="debug"></div>
-<!-- /DEBUG -->
-
[% INCLUDE 'opac-bottom.inc' %]
[% BLOCK jsinclude %]
[% Asset.js("lib/hc-sticky.js") | $raw %]
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
-use vars qw($debug);
use CGI qw ( -utf8 );
use Modern::Perl;
-use vars qw($debug);
-
use CGI qw ( -utf8 );
use Data::Dumper;
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');
my $useborrowerlibrary;
my $borrowernumberlimit;
my $borrowersalreadyapplied; # hashref of borrowers for whom we already applied the fine, so it's only applied once
-my $debug = $ENV{'DEBUG'} || 0;
+my $debug = 0;
my $bigdebug = 0;
GetOptions(
'date-created-marc|c:s' => \$date_created_marc,
'date-modified-marc|m:s' => \$date_modified_marc,
);
-my $debug = $ENV{DEBUG};
+my $debug = 0; # FIXME pass an option for that?
$verbose = 1 if $debug;
# display help ?
url => $url,
user => $user,
password => $password,
- debug => $ENV{DEBUG},
+ debug => 0,
);
if ( ! $file ) {
use Date::Calc qw( Add_Delta_Days Date_to_Days );
-use constant DEBUG => 0;
-
# this is the file version number that we're coded against.
my $FILE_VERSION = '1.0';
undef, # branch
undef, # datedue - let AddRenewal calculate it automatically
$circ->{'date'}, # issuedate
- ) unless ($DEBUG);
+ ) unless (DEBUG);
push @output, {
renew => 1,
$| = 1;
-my $DEBUG = 0;
my $data = CGI->new;
my $imagenumber;
my $cover_images = $biblio->cover_images;
if ( $cover_images->count ) {
$image = $cover_images->next;
- } else {
- warn "No images for this biblio" if $DEBUG;
}
}
}
my $taglist = get_tags({term=>$tag, approved=>1});
$results_hashref->{biblioserver}->{hits} = scalar (@$taglist);
my @marclist = map { C4::Biblio::GetXmlBiblio( $_->{biblionumber} ) } @$taglist;
- $DEBUG and printf STDERR "taglist (%s biblionumber)\nmarclist (%s records)\n", scalar(@$taglist), scalar(@marclist);
$results_hashref->{biblioserver}->{RECORDS} = \@marclist;
# FIXME: tag search and standard search should work together, not exclusively
# FIXME: Because search and standard search don't work together OpacHiddenItems
use Modern::Perl;
-use vars qw($debug);
use CGI qw ( -utf8 );
use autouse 'Data::Dumper' => qw(Dumper);
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
-use vars qw($debug);
use CGI qw ( -utf8 );
use autouse 'Data::Dumper' => qw(Dumper);
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
-use Test::More tests => 13;
+use Test::More tests => 12;
use Test::Warn;
use C4::Auth qw / in_iprange /;
ok(in_iprange(""), "blank list given, no preference set - implies everything goes through.");
ok(in_iprange(), "no list given, no preference set - implies everything goes through.");
ok(in_iprange("192.168.1.1/36"), 'simple invalid ip range/36 with remote ip in it');
-$ENV{DEBUG} = 1;
-warning_like { in_iprange("192.168.1.1/36") }
- qr/cidrlookup failed for/,
- 'noisy simple invalid ip range/36 with remote ip in it';
$ncpu = Sys::CPU::cpu_count();
}
-print "Using $ncpu CPUs...\n"
- if $ENV{DEBUG};
-
my $pm = Parallel::ForkManager->new($ncpu);
foreach my $d (@dirs) {
my $builder = t::lib::TestBuilder->new();
-$ENV{ DEBUG } = 0;
-
my $patron_category = $builder->build({ source => 'Category', value => { category_type => 'P', enrolmentfee => 0 } });
subtest 'Tests for CanBookBeIssued related to dateexpiry' => sub {
use Test::More;
use Test::MockModule;
-use vars qw($debug $koha $dbh $config $ret);
+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'";