From 1575d5c34a2c6235bbf6a5010f8a8c142fe47079 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 11 Jul 2014 21:39:23 -0700 Subject: Switch to Module::Build for the Perl module The wallet server now requires Perl 5.8 or later (instead of 5.006 in previous versions) and is now built with Module::Build instead of ExtUtils::MakeMaker. This should be transparent to anyone not working with the source code, since Perl 5.8 was released in 2002, but Module::Build is now required to build the wallet server. It is included in some versions of Perl, or can be installed separately from CPAN, distribution packages, or other sources. Also reorganize the test suite to use subdirectories. Change-Id: Id06120ba2bad1ebbfee3d8a48ca2f25869463165 Reviewed-on: https://gerrit.stanford.edu/1530 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/lib/Wallet/Object/Base.pm | 1015 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1015 insertions(+) create mode 100644 perl/lib/Wallet/Object/Base.pm (limited to 'perl/lib/Wallet/Object/Base.pm') diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm new file mode 100644 index 0000000..8debac9 --- /dev/null +++ b/perl/lib/Wallet/Object/Base.pm @@ -0,0 +1,1015 @@ +# Wallet::Object::Base -- Parent class for any object stored in the wallet. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Object::Base; +require 5.006; + +use strict; +use vars qw($VERSION); + +use DBI; +use POSIX qw(strftime); +use Text::Wrap qw(wrap); +use Wallet::ACL; + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.06'; + +############################################################################## +# Constructors +############################################################################## + +# Initialize an object from the database. Verifies that the object already +# exists with the given type, and if it does, returns a new blessed object of +# the specified class. Stores the database handle to use, the name, and the +# type in the object. If the object doesn't exist, returns undef. This will +# probably be usable as-is by most object types. +sub new { + my ($class, $type, $name, $schema) = @_; + my %search = (ob_type => $type, + ob_name => $name); + my $object = $schema->resultset('Object')->find (\%search); + die "cannot find ${type}:${name}\n" + unless ($object and $object->ob_name eq $name); + my $self = { + schema => $schema, + name => $name, + type => $type, + }; + bless ($self, $class); + return $self; +} + +# Create a new object in the database of the specified name and type, setting +# the ob_created_* fields accordingly, and returns a new blessed object of the +# specified class. Stores the database handle to use, the name, and the type +# in the object. Subclasses may need to override this to do additional setup. +sub create { + my ($class, $type, $name, $schema, $user, $host, $time) = @_; + $time ||= time; + die "invalid object type\n" unless $type; + die "invalid object name\n" unless $name; + my $guard = $schema->txn_scope_guard; + eval { + my %record = (ob_type => $type, + ob_name => $name, + ob_created_by => $user, + ob_created_from => $host, + ob_created_on => strftime ('%Y-%m-%d %T', + localtime $time)); + $schema->resultset('Object')->create (\%record); + + %record = (oh_type => $type, + oh_name => $name, + oh_action => 'create', + oh_by => $user, + oh_from => $host, + oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + $schema->resultset('ObjectHistory')->create (\%record); + + $guard->commit; + }; + if ($@) { + die "cannot create object ${type}:${name}: $@\n"; + } + my $self = { + schema => $schema, + name => $name, + type => $type, + }; + bless ($self, $class); + return $self; +} + +############################################################################## +# Utility functions +############################################################################## + +# Set or return the error stashed in the object. +sub error { + my ($self, @error) = @_; + if (@error) { + my $error = join ('', @error); + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + $self->{error} = $error; + } + return $self->{error}; +} + +# Returns the type of the object. +sub type { + my ($self) = @_; + return $self->{type}; +} + +# Returns the name of the object. +sub name { + my ($self) = @_; + return $self->{name}; +} + +# Record a global object action for this object. Takes the action (which must +# be one of get or store), and the trace information: user, host, and time. +# Returns true on success and false on failure, setting error appropriately. +# +# This function commits its transaction when complete and should not be called +# inside another transaction. +sub log_action { + my ($self, $action, $user, $host, $time) = @_; + unless ($action =~ /^(get|store)\z/) { + $self->error ("invalid history action $action"); + return; + } + + # We have two traces to record, one in the object_history table and one in + # the object record itself. Commit both changes as a transaction. We + # assume that AutoCommit is turned off. + my $guard = $self->{schema}->txn_scope_guard; + eval { + my %record = (oh_type => $self->{type}, + oh_name => $self->{name}, + oh_action => $action, + oh_by => $user, + oh_from => $host, + oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + $self->{schema}->resultset('ObjectHistory')->create (\%record); + + my %search = (ob_type => $self->{type}, + ob_name => $self->{name}); + my $object = $self->{schema}->resultset('Object')->find (\%search); + if ($action eq 'get') { + $object->ob_downloaded_by ($user); + $object->ob_downloaded_from ($host); + $object->ob_downloaded_on (strftime ('%Y-%m-%d %T', + localtime $time)); + } elsif ($action eq 'store') { + $object->ob_stored_by ($user); + $object->ob_stored_from ($host); + $object->ob_stored_on (strftime ('%Y-%m-%d %T', + localtime $time)); + } + $object->update; + $guard->commit; + }; + if ($@) { + my $id = $self->{type} . ':' . $self->{name}; + $self->error ("cannot update history for $id: $@"); + return; + } + return 1; +} + +# Record a setting change for this object. Takes the field, the old value, +# the new value, and the trace information (user, host, and time). The field +# may have the special value "type_data " in which case the value after +# the whitespace is used as the type_field value. +# +# This function does not commit and does not catch exceptions. It should +# normally be called as part of a larger transaction that implements the +# setting change and should be committed with that change. +sub log_set { + my ($self, $field, $old, $new, $user, $host, $time) = @_; + my $type_field; + if ($field =~ /^type_data\s+/) { + ($field, $type_field) = split (' ', $field, 2); + } + my %fields = map { $_ => 1 } + qw(owner acl_get acl_store acl_show acl_destroy acl_flags expires + comment flags type_data); + unless ($fields{$field}) { + die "invalid history field $field"; + } + + my %record = (oh_type => $self->{type}, + oh_name => $self->{name}, + oh_action => 'set', + oh_field => $field, + oh_type_field => $type_field, + oh_old => $old, + oh_new => $new, + oh_by => $user, + oh_from => $host, + oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + $self->{schema}->resultset('ObjectHistory')->create (\%record); +} + +############################################################################## +# Get/set values +############################################################################## + +# Set a particular attribute. Takes the attribute to set and its new value. +# Returns undef on failure and true on success. +sub _set_internal { + my ($self, $attr, $value, $user, $host, $time) = @_; + if ($attr !~ /^[a-z_]+\z/) { + $self->error ("invalid attribute $attr"); + return; + } + $time ||= time; + my $name = $self->{name}; + my $type = $self->{type}; + if ($self->flag_check ('locked')) { + $self->error ("cannot modify ${type}:${name}: object is locked"); + return; + } + + my $guard = $self->{schema}->txn_scope_guard; + eval { + my %search = (ob_type => $type, + ob_name => $name); + my $object = $self->{schema}->resultset('Object')->find (\%search); + my $old = $object->get_column ("ob_$attr"); + + $object->update ({ "ob_$attr" => $value }); + $self->log_set ($attr, $old, $value, $user, $host, $time); + $guard->commit; + }; + if ($@) { + my $id = $self->{type} . ':' . $self->{name}; + $self->error ("cannot set $attr on $id: $@"); + return; + } + return 1; +} + +# Get a particular attribute. Returns the attribute value or undef if the +# value isn't set or on a database error. The two cases can be distinguished +# by whether $self->{error} is set. +sub _get_internal { + my ($self, $attr) = @_; + undef $self->{error}; + if ($attr !~ /^[a-z_]+\z/) { + $self->error ("invalid attribute $attr"); + return; + } + $attr = 'ob_' . $attr; + my $name = $self->{name}; + my $type = $self->{type}; + my $value; + eval { + my %search = (ob_type => $type, + ob_name => $name); + my $object = $self->{schema}->resultset('Object')->find (\%search); + $value = $object->get_column ($attr); + }; + if ($@) { + $self->error ($@); + return; + } + return $value; +} + +# Get or set an ACL on an object. Takes the type of ACL and, if setting, the +# new ACL identifier. If setting it, trace information must also be provided. +sub acl { + my ($self, $type, $id, $user, $host, $time) = @_; + if ($type !~ /^(get|store|show|destroy|flags)\z/) { + $self->error ("invalid ACL type $type"); + return; + } + my $attr = "acl_$type"; + if ($id) { + my $acl; + eval { $acl = Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + return $self->_set_internal ($attr, $acl->id, $user, $host, $time); + } elsif (defined $id) { + return $self->_set_internal ($attr, undef, $user, $host, $time); + } else { + return $self->_get_internal ($attr); + } +} + +# Get or set an attribute on an object. Takes the name of the attribute and, +# if setting, the values and trace information. The values must be provided +# as a reference to an array, even if there is only one value. +# +# Attributes are used by backends for backend-specific information (such as +# enctypes for a keytab). The default implementation rejects all attribute +# names as unknown. +sub attr { + my ($self, $attr, $values, $user, $host, $time) = @_; + $self->error ("unknown attribute $attr"); + return; +} + +# Format the object attributes for inclusion in show(). The default +# implementation just returns the empty string. +sub attr_show { + my ($self) = @_; + return ''; +} + +# Get or set the comment value of an object. If setting it, trace information +# must also be provided. +sub comment { + my ($self, $comment, $user, $host, $time) = @_; + if ($comment) { + return $self->_set_internal ('comment', $comment, $user, $host, $time); + } elsif (defined $comment) { + return $self->_set_internal ('comment', undef, $user, $host, $time); + } else { + return $self->_get_internal ('comment'); + } +} + +# Get or set the expires value of an object. Expects an expiration time in +# seconds since epoch. If setting the expiration, trace information must also +# be provided. +sub expires { + my ($self, $expires, $user, $host, $time) = @_; + if ($expires) { + if ($expires !~ /^\d{4}-\d\d-\d\d( \d\d:\d\d:\d\d)?\z/) { + $self->error ("malformed expiration time $expires"); + return; + } + return $self->_set_internal ('expires', $expires, $user, $host, $time); + } elsif (defined $expires) { + return $self->_set_internal ('expires', undef, $user, $host, $time); + } else { + return $self->_get_internal ('expires'); + } +} + +# Get or set the owner of an object. If setting it, trace information must +# also be provided. +sub owner { + my ($self, $owner, $user, $host, $time) = @_; + if ($owner) { + my $acl; + eval { $acl = Wallet::ACL->new ($owner, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + return $self->_set_internal ('owner', $acl->id, $user, $host, $time); + } elsif (defined $owner) { + return $self->_set_internal ('owner', undef, $user, $host, $time); + } else { + return $self->_get_internal ('owner'); + } +} + +############################################################################## +# Flags +############################################################################## + +# Check whether a flag is set on the object. Returns true if set, 0 if not +# set, and undef on error. +sub flag_check { + my ($self, $flag) = @_; + my $name = $self->{name}; + my $type = $self->{type}; + my $schema = $self->{schema}; + my $value; + eval { + my %search = (fl_type => $type, + fl_name => $name, + fl_flag => $flag); + my $flag = $schema->resultset('Flag')->find (\%search); + if (not defined $flag) { + $value = 0; + } else { + $value = $flag->fl_flag; + } + }; + if ($@) { + $self->error ("cannot check flag $flag for ${type}:${name}: $@"); + return; + } else { + return ($value) ? 1 : 0; + } +} + +# Clear a flag on an object. Takes the flag and trace information. Returns +# true on success and undef on failure. +sub flag_clear { + my ($self, $flag, $user, $host, $time) = @_; + $time ||= time; + my $name = $self->{name}; + my $type = $self->{type}; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; + eval { + my %search = (fl_type => $type, + fl_name => $name, + fl_flag => $flag); + my $flag = $schema->resultset('Flag')->find (\%search); + unless (defined $flag) { + die "flag not set\n"; + } + $flag->delete; + $self->log_set ('flags', $flag->fl_flag, undef, $user, $host, $time); + $guard->commit; + }; + if ($@) { + $self->error ("cannot clear flag $flag on ${type}:${name}: $@"); + return; + } + return 1; +} + +# List the flags on an object. Returns a list of flag names, which may be +# empty. On error, returns the empty list. The caller should call error() in +# this case to determine if an error occurred. +sub flag_list { + my ($self) = @_; + undef $self->{error}; + my @flags; + eval { + my %search = (fl_type => $self->{type}, + fl_name => $self->{name}); + my %attrs = (order_by => 'fl_flag'); + my @flags_rs = $self->{schema}->resultset('Flag')->search (\%search, + \%attrs); + for my $flag (@flags_rs) { + push (@flags, $flag->fl_flag); + } + }; + if ($@) { + my $id = $self->{type} . ':' . $self->{name}; + $self->error ("cannot retrieve flags for $id: $@"); + return; + } else { + return @flags; + } +} + +# Set a flag on an object. Takes the flag and trace information. Returns +# true on success and undef on failure. +sub flag_set { + my ($self, $flag, $user, $host, $time) = @_; + $time ||= time; + my $name = $self->{name}; + my $type = $self->{type}; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; + eval { + my %search = (fl_type => $type, + fl_name => $name, + fl_flag => $flag); + my $flag = $schema->resultset('Flag')->find (\%search); + if (defined $flag) { + die "flag already set\n"; + } + $flag = $schema->resultset('Flag')->create (\%search); + $self->log_set ('flags', undef, $flag->fl_flag, $user, $host, $time); + $guard->commit; + }; + if ($@) { + $self->error ("cannot set flag $flag on ${type}:${name}: $@"); + return; + } + return 1; +} + +############################################################################## +# History +############################################################################## + +# Expand a given ACL id to add its name, for readability. Returns the +# original id alone if there was a problem finding the name. +sub format_acl_id { + my ($self, $id) = @_; + my $name = $id; + + my %search = (ac_id => $id); + my $acl_rs = $self->{schema}->resultset('Acl')->find (\%search); + if (defined $acl_rs) { + $name = $acl_rs->ac_name . " ($id)"; + } + + return $name; +} + +# Return the formatted history for a given object or undef on error. +# Currently always returns the complete history, but eventually will need to +# provide some way of showing only recent entries. +sub history { + my ($self) = @_; + my $output = ''; + eval { + my %search = (oh_type => $self->{type}, + oh_name => $self->{name}); + my %attrs = (order_by => 'oh_on'); + my @history = $self->{schema}->resultset('ObjectHistory') + ->search (\%search, \%attrs); + + for my $history_rs (@history) { + $output .= sprintf ("%s %s ", $history_rs->oh_on->ymd, + $history_rs->oh_on->hms); + + my $old = $history_rs->oh_old; + my $new = $history_rs->oh_new; + my $action = $history_rs->oh_action; + my $field = $history_rs->oh_field; + + if ($action eq 'set' and $field eq 'flags') { + if (defined ($new)) { + $output .= "set flag $new"; + } elsif (defined ($old)) { + $output .= "clear flag $old"; + } + } elsif ($action eq 'set' and $field eq 'type_data') { + my $attr = $history_rs->oh_type_field; + if (defined ($old) and defined ($new)) { + $output .= "set attribute $attr to $new (was $old)"; + } elsif (defined ($old)) { + $output .= "remove $old from attribute $attr"; + } elsif (defined ($new)) { + $output .= "add $new to attribute $attr"; + } + } elsif ($action eq 'set' + and ($field eq 'owner' or $field =~ /^acl_/)) { + $old = $self->format_acl_id ($old) if defined ($old); + $new = $self->format_acl_id ($new) if defined ($new); + if (defined ($old) and defined ($new)) { + $output .= "set $field to $new (was $old)"; + } elsif (defined ($new)) { + $output .= "set $field to $new"; + } elsif (defined ($old)) { + $output .= "unset $field (was $old)"; + } + } elsif ($action eq 'set') { + if (defined ($old) and defined ($new)) { + $output .= "set $field to $new (was $old)"; + } elsif (defined ($new)) { + $output .= "set $field to $new"; + } elsif (defined ($old)) { + $output .= "unset $field (was $old)"; + } + } else { + $output .= $action; + } + $output .= sprintf ("\n by %s from %s\n", $history_rs->oh_by, + $history_rs->oh_from); + } + }; + if ($@) { + my $id = $self->{type} . ':' . $self->{name}; + $self->error ("cannot read history for $id: $@"); + return; + } + return $output; +} + +############################################################################## +# Object manipulation +############################################################################## + +# The get methods must always be overridden by the subclass. +sub get { die "Do not instantiate Wallet::Object::Base directly\n"; } + +# Provide a default store implementation that returns an immutable object +# error so that auto-generated types don't have to provide their own. +sub store { + my ($self, $data, $user, $host, $time) = @_; + my $id = $self->{type} . ':' . $self->{name}; + if ($self->flag_check ('locked')) { + $self->error ("cannot store $id: object is locked"); + return; + } + $self->error ("cannot store $id: object type is immutable"); + return; +} + +# The default show function. This may be adequate for many types; types that +# have additional data should call this method, grab the results, and then add +# their data on to the end. +sub show { + my ($self) = @_; + my $name = $self->{name}; + my $type = $self->{type}; + my @attrs = ([ ob_type => 'Type' ], + [ ob_name => 'Name' ], + [ ob_owner => 'Owner' ], + [ ob_acl_get => 'Get ACL' ], + [ ob_acl_store => 'Store ACL' ], + [ ob_acl_show => 'Show ACL' ], + [ ob_acl_destroy => 'Destroy ACL' ], + [ ob_acl_flags => 'Flags ACL' ], + [ ob_expires => 'Expires' ], + [ ob_comment => 'Comment' ], + [ ob_created_by => 'Created by' ], + [ ob_created_from => 'Created from' ], + [ ob_created_on => 'Created on' ], + [ ob_stored_by => 'Stored by' ], + [ ob_stored_from => 'Stored from' ], + [ ob_stored_on => 'Stored on' ], + [ ob_downloaded_by => 'Downloaded by' ], + [ ob_downloaded_from => 'Downloaded from' ], + [ ob_downloaded_on => 'Downloaded on' ]); + my $fields = join (', ', map { $_->[0] } @attrs); + my @data; + my $object_rs; + eval { + my %search = (ob_type => $type, + ob_name => $name); + $object_rs = $self->{schema}->resultset('Object')->find (\%search); + }; + if ($@) { + $self->error ("cannot retrieve data for ${type}:${name}: $@"); + return; + } + my $output = ''; + my @acls; + + # Format the results. We use a hack to insert the flags before the first + # trace field since they're not a field in the object in their own right. + # The comment should be word-wrapped at 80 columns. + for my $i (0 .. $#attrs) { + my $field = $attrs[$i][0]; + my $fieldtext = $attrs[$i][1]; + next unless my $value = $object_rs->get_column ($field); + + if ($field eq 'ob_comment' && length ($value) > 79 - 17) { + local $Text::Wrap::columns = 80; + local $Text::Wrap::unexpand = 0; + $value = wrap (' ' x 17, ' ' x 17, $value); + $value =~ s/^ {17}//; + } + if ($field eq 'ob_created_by') { + my @flags = $self->flag_list; + if (not @flags and $self->error) { + return; + } + if (@flags) { + $output .= sprintf ("%15s: %s\n", 'Flags', "@flags"); + } + my $attr_output = $self->attr_show; + if (not defined $attr_output) { + return; + } + $output .= $attr_output; + } + if ($field =~ /^ob_(owner|acl_)/) { + my $acl = eval { Wallet::ACL->new ($value, $self->{schema}) }; + if ($acl and not $@) { + $value = $acl->name || $value; + push (@acls, [ $acl, $value ]); + } + } + $output .= sprintf ("%15s: %s\n", $fieldtext, $value); + } + if (@acls) { + my %seen; + @acls = grep { !$seen{$_->[1]}++ } @acls; + for my $acl (@acls) { + $output .= "\n" . $acl->[0]->show; + } + } + return $output; +} + +# The default destroy function only destroys the database metadata. Generally +# subclasses need to override this to destroy whatever additional information +# is stored about this object. +sub destroy { + my ($self, $user, $host, $time) = @_; + $time ||= time; + my $name = $self->{name}; + my $type = $self->{type}; + if ($self->flag_check ('locked')) { + $self->error ("cannot destroy ${type}:${name}: object is locked"); + return; + } + my $guard = $self->{schema}->txn_scope_guard; + eval { + + # Remove any flags that may exist for the record. + my %search = (fl_type => $type, + fl_name => $name); + $self->{schema}->resultset('Flag')->search (\%search)->delete; + + # Remove any object records + %search = (ob_type => $type, + ob_name => $name); + $self->{schema}->resultset('Object')->search (\%search)->delete; + + # And create a new history object for the destroy action. + my %record = (oh_type => $type, + oh_name => $name, + oh_action => 'destroy', + oh_by => $user, + oh_from => $host, + oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + $self->{schema}->resultset('ObjectHistory')->create (\%record); + $guard->commit; + }; + if ($@) { + $self->error ("cannot destroy ${type}:${name}: $@"); + return; + } + return 1; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +Wallet::Object::Base - Generic parent class for wallet objects + +=for stopwords +DBH HOSTNAME DATETIME ACL backend metadata timestamp Allbery wallet-backend +backend-specific subclasses + +=head1 SYNOPSIS + + package Wallet::Object::Simple; + @ISA = qw(Wallet::Object::Base); + sub get { + my ($self, $user, $host, $time) = @_; + $self->log_action ('get', $user, $host, $time) or return; + return "Some secure data"; + } + +=head1 DESCRIPTION + +Wallet::Object::Base is the generic parent class for wallet objects (data +types that can be stored in the wallet system). It provides default +functions and behavior, including handling generic object settings. All +handlers for objects stored in the wallet should inherit from it. It is +not used directly. + +=head1 PUBLIC CLASS METHODS + +The following methods are called by the rest of the wallet system and +should be implemented by all objects stored in the wallet. They should be +called with the desired wallet object class as the first argument +(generally using the Wallet::Object::Type->new syntax). + +=over 4 + +=item new(TYPE, NAME, DBH) + +Creates a new object with the given object type and name, based on data +already in the database. This method will only succeed if an object of +the given TYPE and NAME is already present in the wallet database. If no +such object exits, throws an exception. Otherwise, returns an object +blessed into the class used for the new() call (so subclasses can leave +this method alone and not override it). + +Takes a Wallet::Schema object, which is stored in the object and used +for any further operations. + +=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME]) + +Similar to new() but instead creates a new entry in the database. This +method will throw an exception if an entry for that type and name already +exists in the database or if creating the database record fails. +Otherwise, a new database entry will be created with that type and name, +no owner, no ACLs, no expiration, no flags, and with created by, from, and +on set to the PRINCIPAL, HOSTNAME, and DATETIME parameters. If DATETIME +isn't given, the current time is used. The database handle is treated as +with new(). + +=back + +=head1 PUBLIC INSTANCE METHODS + +The following methods may be called on instantiated wallet objects. +Normally, the only methods that a subclass will need to override are +get(), store(), show(), and destroy(). + +If the locked flag is set on an object, no actions may be performed on +that object except for the flag methods and show(). All other actions +will be rejected with an error saying the object is locked. + +=over 4 + +=item acl(TYPE [, ACL, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves a given object ACL as a numeric ACL ID. TYPE must be +one of C, C, C, C, or C, corresponding +to the ACLs kept on an object. If no other arguments are given, returns +the current ACL setting as an ACL ID or undef if that ACL isn't set. If +other arguments are given, change that ACL to ACL and return true on +success and false on failure. Pass in the empty string for ACL to clear +the ACL. The other arguments are used for logging and history and should +indicate the user and host from which the change is made and the time of +the change. + +=item attr(ATTRIBUTE [, VALUES, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves a given object attribute. Attributes are used to store +backend-specific information for a particular object type and ATTRIBUTE +must be an attribute type known to the underlying object implementation. +The default implementation of this method rejects all attributes as +unknown. + +If no other arguments besides ATTRIBUTE are given, returns the values of +that attribute, if any, as a list. On error, returns the empty list. To +distinguish between an error and an empty return, call error() afterward. +It is guaranteed to return undef unless there was an error. + +If other arguments are given, sets the given ATTRIBUTE values to VALUES, +which must be a reference to an array (even if only one value is being +set). Pass a reference to an empty array to clear the attribute values. +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. Returns true on success and false on failure. + +=item attr_show() + +Returns a formatted text description of the type-specific attributes of +the object, or undef on error. The default implementation of this method +always returns the empty string. If there are any type-specific +attributes set, this method should return that metadata, formatted as key: +value pairs with the keys right-aligned in the first 15 characters, +followed by a space, a colon, and the value. + +=item comment([COMMENT, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves the comment associated with an object. If no arguments +are given, returns the current comment or undef if no comment is set. If +arguments are given, change the comment to COMMENT and return true on +success and false on failure. Pass in the empty string for COMMENT to +clear the comment. + +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. + +=item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) + +Destroys the object by removing all record of it from the database. The +Wallet::Object::Base implementation handles the generic database work, but +any subclass should override this method to do any deletion of files or +entries in external databases and any other database entries and then call +the parent method to handle the generic database cleanup. Returns true on +success and false on failure. The arguments are used for logging and +history and should indicate the user and host from which the change is +made and the time of the change. + +=item error([ERROR ...]) + +Returns the error of the last failing operation or undef if no operations +have failed. Callers should call this function to get the error message +after an undef return from any other instance method. + +For the convenience of child classes, this method can also be called with +one or more error strings. If so, those strings are concatenated +together, trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is +stored as the error. Only child classes should call this method with an +error string. + +=item expires([EXPIRES, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves the expiration date of an object. If no arguments are +given, returns the current expiration or undef if no expiration is set. +If arguments are given, change the expiration to EXPIRES and return true +on success and false on failure. EXPIRES must be in the format +C, although the time portion may be omitted. Pass in +the empty string for EXPIRES to clear the expiration date. + +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. + +=item flag_check(FLAG) + +Check whether the given flag is set on an object. Returns true if set, +C<0> if not set, and undef on error. + +=item flag_clear(FLAG, PRINCIPAL, HOSTNAME [, DATETIME]) + +Clears FLAG on an object. Returns true on success and false on failure. +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. + +=item flag_list() + +List the flags set on an object. If no flags are set, returns the empty +list. On failure, returns an empty list. To distinguish between the +empty response and an error, the caller should call error() after an empty +return. It is guaranteed to return undef if there was no error. + +=item flag_set(FLAG, PRINCIPAL, HOSTNAME [, DATETIME]) + +Sets FLAG on an object. Returns true on success and false on failure. +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. + +=item get(PRINCIPAL, HOSTNAME [, DATETIME]) + +An object implementation must override this method with one that returns +either the data of the object or undef on some error, using the provided +arguments to update history information. The Wallet::Object::Base +implementation just throws an exception. + +=item history() + +Returns the formatted history for the object. There will be two lines for +each action on the object. The first line has the timestamp of the action +and the action, and the second line gives the user who performed the +action and the host from which they performed it (based on the trace +information passed into the other object methods). + +=item name() + +Returns the object's name. + +=item owner([OWNER, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves the owner of an object as a numeric ACL ID. If no +arguments are given, returns the current owner ACL ID or undef if none is +set. If arguments are given, change the owner to OWNER and return true on +success and false on failure. Pass in the empty string for OWNER to clear +the owner. The other arguments are used for logging and history and +should indicate the user and host from which the change is made and the +time of the change. + +=item show() + +Returns a formatted text description of the object suitable for human +display, or undef on error. All of the base metadata about the object, +formatted as key: value pairs with the keys aligned in the first 15 +characters followed by a space, a colon, and the value. The attr_show() +method of the object is also called and any formatted output it returns +will be included. If any ACLs or an owner are set, after this data there +is a blank line and then the information for each unique ACL, separated by +blank lines. + +=item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME]) + +Store user-supplied data into the given object. This may not be supported +by all backends (for instance, backends that automatically generate the +data will not support this). The default implementation rejects all +store() calls with an error message saying that the object is immutable. + +=item type() + +Returns the object's type. + +=back + +=head1 UTILITY METHODS + +The following instance methods should not be called externally but are +provided for subclasses to call to implement some generic actions. + +=over 4 + +=item log_action (ACTION, PRINCIPAL, HOSTNAME, DATETIME) + +Updates the history tables and trace information appropriately for ACTION, +which should be either C or C. No other changes are made to +the database, just updates of the history table and trace fields with the +provided data about who performed the action and when. + +This function commits its transaction when complete and therefore should +not be called inside another transaction. Normally it's called as a +separate transaction after the data is successfully stored or retrieved. + +=item log_set (FIELD, OLD, NEW, PRINCIPAL, HOSTNAME, DATETIME) + +Updates the history tables for the change in a setting value for an +object. FIELD should be one of C, C, C, +C, C, C, C, C, or a +value starting with C followed by a space and a type-specific +field name. The last form is the most common form used by a subclass. +OLD is the previous value of the field or undef if the field was unset, +and NEW is the new value of the field or undef if the field should be +unset. + +This function does not commit and does not catch database exceptions. It +should normally be called as part of a larger transaction that implements +the change in the setting. + +=back + +=head1 SEE ALSO + +wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut -- cgit v1.2.3 From 1329e6db944a6fce5578b249de08a8250a920877 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 11 Jul 2014 22:36:11 -0700 Subject: Test for Perl strict and minimum version Fix strictness issues across the whole code base, and ensure that all Perl scripts enable warnings. (Hopefully enabling warnings won't cause problems for the server.) Change-Id: I4dee49f7a6bcbeeee21d74bf61a1fd26514f832c Reviewed-on: https://gerrit.stanford.edu/1532 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 8 ++-- README | 34 ++++++++++++----- contrib/wallet-summary | 33 +++++++++-------- contrib/wallet-unknown-hosts | 36 ++++++++++-------- perl/lib/Wallet/ACL.pm | 3 +- perl/lib/Wallet/ACL/Base.pm | 3 +- perl/lib/Wallet/ACL/Krb5.pm | 3 +- perl/lib/Wallet/ACL/Krb5/Regex.pm | 3 +- perl/lib/Wallet/ACL/LDAP/Attribute.pm | 3 +- perl/lib/Wallet/ACL/NetDB.pm | 3 +- perl/lib/Wallet/ACL/NetDB/Root.pm | 3 +- perl/lib/Wallet/Admin.pm | 3 +- perl/lib/Wallet/Config.pm | 1 + perl/lib/Wallet/Database.pm | 3 +- perl/lib/Wallet/Kadmin.pm | 3 +- perl/lib/Wallet/Kadmin/Heimdal.pm | 1 + perl/lib/Wallet/Kadmin/MIT.pm | 3 +- perl/lib/Wallet/Object/Base.pm | 3 +- perl/lib/Wallet/Object/Duo.pm | 1 + perl/lib/Wallet/Object/File.pm | 3 +- perl/lib/Wallet/Object/Keytab.pm | 3 +- perl/lib/Wallet/Object/WAKeyring.pm | 3 +- perl/lib/Wallet/Report.pm | 3 +- perl/lib/Wallet/Server.pm | 3 +- perl/t/data/perl.conf | 7 ++++ perl/t/general/acl.t | 5 ++- perl/t/general/admin.t | 7 +++- perl/t/general/config.t | 7 +++- perl/t/general/init.t | 5 ++- perl/t/general/report.t | 7 +++- perl/t/general/server.t | 7 +++- perl/t/lib/Util.pm | 3 +- perl/t/object/base.t | 5 ++- perl/t/object/file.t | 7 +++- perl/t/object/keytab.t | 11 ++++-- perl/t/style/minimum-version.t | 47 ++++++++++++++++++++++++ perl/t/style/strict.t | 56 ++++++++++++++++++++++++++++ perl/t/util/kadmin.t | 7 +++- perl/t/verifier/basic.t | 5 ++- perl/t/verifier/ldap-attr.t | 5 ++- perl/t/verifier/netdb.t | 7 +++- server/keytab-backend | 1 + server/wallet-backend | 1 + tests/TESTS | 2 + tests/client/full-t.in | 12 +++--- tests/client/prompt-t.in | 14 ++++--- tests/data/fake-kadmin | 7 +++- tests/perl/minimum-version-t | 69 +++++++++++++++++++++++++++++++++++ tests/perl/strict-t | 66 +++++++++++++++++++++++++++++++++ 49 files changed, 437 insertions(+), 98 deletions(-) create mode 100644 perl/t/data/perl.conf create mode 100755 perl/t/style/minimum-version.t create mode 100755 perl/t/style/strict.t create mode 100755 tests/perl/minimum-version-t create mode 100755 tests/perl/strict-t (limited to 'perl/lib/Wallet/Object/Base.pm') diff --git a/Makefile.am b/Makefile.am index 19dbe11..8e65151 100644 --- a/Makefile.am +++ b/Makefile.am @@ -66,6 +66,7 @@ PERL_FILES = perl/Build.PL perl/MANIFEST perl/MANIFEST.SKIP \ perl/t/general/server.t perl/t/lib/Util.pm perl/t/object/base.t \ perl/t/object/duo.t perl/t/object/file.t perl/t/object/keytab.t \ perl/t/object/wa-keyring.t perl/t/policy/stanford.t \ + perl/t/style/minimum-version.t perl/t/style/strict.t \ perl/t/util/kadmin.t perl/t/verifier/basic.t \ perl/t/verifier/ldap-attr.t perl/t/verifier/netdb.t @@ -99,9 +100,10 @@ EXTRA_DIST = .gitignore LICENSE autogen client/wallet.pod \ tests/data/fake-keytab-partial-result tests/data/fake-keytab-rekey \ tests/data/fake-keytab-unknown tests/data/fake-srvtab \ tests/data/full.conf tests/data/perl.conf tests/data/wallet.conf \ - tests/docs/pod-spelling-t tests/docs/pod-t tests/server/admin-t \ - tests/server/backend-t tests/server/keytab-t tests/server/report-t \ - tests/tap/kerberos.sh tests/tap/libtap.sh \ + tests/docs/pod-spelling-t tests/docs/pod-t \ + tests/perl/minimum-version-t tests/perl/strict-t \ + tests/server/admin-t tests/server/backend-t tests/server/keytab-t \ + tests/server/report-t tests/tap/kerberos.sh tests/tap/libtap.sh \ tests/tap/perl/Test/RRA.pm tests/tap/perl/Test/RRA/Automake.pm \ tests/tap/perl/Test/RRA/Config.pm tests/tap/remctl.sh \ tests/util/xmalloc-t $(PERL_FILES) diff --git a/README b/README index e72bc80..ef910bd 100644 --- a/README +++ b/README @@ -118,16 +118,30 @@ REQUIREMENTS server. To run the full test suite, all of the above software requirements must - be met. Tests requiring some bit of software that's not installed - should be skipped, but not all the permutations have been checked. The - full test suite also requires the Test::Pod Perl module (available from - CPAN), that remctld be installed and available on the user's path or in - /usr/local/sbin or /usr/sbin, that sqlite3 be installed and available on - the user's path, that test cases can run services on and connect to port - 14373 on 127.0.0.1, and that kinit and either kvno or kgetcred (which - come with Kerberos) be installed and available on the user's path. The - full test suite also requires a local keytab and some additional - configuration. + be met. The full test suite also requires that remctld be installed and + available on the user's path or in /usr/local/sbin or /usr/sbin, that + sqlite3 be installed and available on the user's path, that test cases + can run services on and connect to port 14373 on 127.0.0.1, and that + kinit and either kvno or kgetcred (which come with Kerberos) be + installed and available on the user's path. The full test suite also + requires a local keytab and some additional configuration. + + The following additional Perl modules will be used if present: + + Test::MinimumVersion + Test::Pod + Test::Spelling + Test::Strict + + All are available on CPAN. Those tests will be skipped if the modules + are not available. + + To enable tests that don't detect functionality problems but are used to + sanity-check the release, set the environment variable RELEASE_TESTING + to a true value. To enable tests that may be sensitive to the local + environment or that produce a lot of false positives without uncovering + many problems, set the environment variable AUTHOR_TESTING to a true + value. To bootstrap from a Git checkout, or if you change the Automake files and need to regenerate Makefile.in, you will need Automake 1.11 or diff --git a/contrib/wallet-summary b/contrib/wallet-summary index 55501ad..5cbf6e0 100755 --- a/contrib/wallet-summary +++ b/contrib/wallet-summary @@ -1,7 +1,22 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Summarize keytabs in the wallet database. +############################################################################## +# Modules and declarations +############################################################################## + +require 5.005; + +use strict; +use vars qw($ADDRESS $DUMPFILE @PATTERNS $REPORTS); +use warnings; + +use Getopt::Long qw(GetOptions); +use File::Path qw(mkpath); +use POSIX qw(strftime); +use Wallet::Report (); + ############################################################################## # Site configuration ############################################################################## @@ -29,20 +44,6 @@ $ADDRESS = 'nobody@example.com'; [qr(^webauth/), 'webauth/*', 'WebAuth v3'], [qr(^service/), 'service/*', 'Service principals']); -############################################################################## -# Modules and declarations -############################################################################## - -require 5.005; - -use strict; -use vars qw($ADDRESS $DUMPFILE @PATTERNS $REPORTS); - -use Getopt::Long qw(GetOptions); -use File::Path qw(mkpath); -use POSIX qw(strftime); -use Wallet::Report (); - ############################################################################## # Database queries ############################################################################## @@ -145,7 +146,7 @@ if ($mail) { } # Run the report. -my @principals = read_dump; +my @principals = read_dump (); report_principals (@principals); # If -m was given, take the saved report and mail it as well. diff --git a/contrib/wallet-unknown-hosts b/contrib/wallet-unknown-hosts index 339983d..50b5a04 100755 --- a/contrib/wallet-unknown-hosts +++ b/contrib/wallet-unknown-hosts @@ -1,7 +1,20 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Report host keytabs in wallet for unknown hosts. +############################################################################## +# Modules and declarations +############################################################################## + +require 5.006; + +use strict; +use warnings; + +use DB_File (); +use Wallet::Report (); +use Wallet::Server (); + ############################################################################## # Site configuration ############################################################################## @@ -22,9 +35,10 @@ our $MIN = 3; our $THRESHOLD = time - 30 * 24 * 60 * 60; # Set up a Net::DNS resolver that will be used by local_check_keytab. +my $DNS; BEGIN { use Net::DNS; - our $DNS = Net::DNS::Resolver->new; + $DNS = Net::DNS::Resolver->new; } # Pre-filter. This is called for all host-based keytabs and is the place to @@ -54,18 +68,6 @@ sub local_check_keytab { return; } -############################################################################## -# Modules and declarations -############################################################################## - -require 5.006; - -use strict; - -use DB_File (); -use Wallet::Report (); -use Wallet::Server (); - ############################################################################## # Utility functions ############################################################################## @@ -97,6 +99,7 @@ sub check_host { # Do a scan of all host-based keytabs in wallet and record those that are not # found in DNS or which should not be used according to site configuration. sub check { + my %history; tie %history, 'DB_File', $HISTORY; my @keytabs = list_keytabs; for my $keytab (@keytabs) { @@ -124,6 +127,7 @@ sub check { # list (given as a threshold time in seconds since epoch). sub report { my ($min, $threshold) = @_; + my %history; tie %history, 'DB_File', $HISTORY; for my $keytab (sort keys %history) { my ($count, $time) = split (',', $history{$keytab}); @@ -142,6 +146,7 @@ sub report { sub purge { my ($user, $min, $threshold) = @_; my $wallet = Wallet::Server->new ($user, 'localhost'); + my %history; tie %history, 'DB_File', $HISTORY; for my $keytab (sort keys %history) { my ($count, $time) = split (',', $history{$keytab}); @@ -161,7 +166,7 @@ sub purge { my $command = shift or die "Usage: $0 (check | report | purge)\n"; if ($command eq 'check') { - check; + check (); } elsif ($command eq 'report') { my ($min, $threshold) = @_; $min = $MIN unless defined ($min); @@ -170,6 +175,7 @@ if ($command eq 'check') { report ($min, $threshold); } elsif ($command eq 'purge') { my $user = $ENV{REMOTE_USER} or die "$0: REMOTE_USER must be set\n"; + my ($min, $threshold) = @_; $min = $MIN unless defined ($min); die "$0: minimum count must be at least 1\n" if $min < 1; $threshold = $THRESHOLD unless defined ($threshold); diff --git a/perl/lib/Wallet/ACL.pm b/perl/lib/Wallet/ACL.pm index 808be3c..9507c64 100644 --- a/perl/lib/Wallet/ACL.pm +++ b/perl/lib/Wallet/ACL.pm @@ -1,7 +1,7 @@ # Wallet::ACL -- Implementation of ACLs in the wallet system. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2013 +# Copyright 2007, 2008, 2010, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL; require 5.006; use strict; +use warnings; use vars qw($VERSION); use DBI; diff --git a/perl/lib/Wallet/ACL/Base.pm b/perl/lib/Wallet/ACL/Base.pm index b6e4ce3..a2b07cc 100644 --- a/perl/lib/Wallet/ACL/Base.pm +++ b/perl/lib/Wallet/ACL/Base.pm @@ -1,7 +1,7 @@ # Wallet::ACL::Base -- Parent class for wallet ACL verifiers. # # Written by Russ Allbery -# Copyright 2007, 2010 +# Copyright 2007, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::Base; require 5.006; use strict; +use warnings; use vars qw($VERSION); # This version should be increased on any code change to this module. Always diff --git a/perl/lib/Wallet/ACL/Krb5.pm b/perl/lib/Wallet/ACL/Krb5.pm index ed0b7df..80d32bd 100644 --- a/perl/lib/Wallet/ACL/Krb5.pm +++ b/perl/lib/Wallet/ACL/Krb5.pm @@ -1,7 +1,7 @@ # Wallet::ACL::Krb5 -- Wallet Kerberos v5 principal ACL verifier. # # Written by Russ Allbery -# Copyright 2007, 2010 +# Copyright 2007, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::Krb5; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::ACL::Base; diff --git a/perl/lib/Wallet/ACL/Krb5/Regex.pm b/perl/lib/Wallet/ACL/Krb5/Regex.pm index 30f5527..4934cfc 100644 --- a/perl/lib/Wallet/ACL/Krb5/Regex.pm +++ b/perl/lib/Wallet/ACL/Krb5/Regex.pm @@ -1,7 +1,7 @@ # Wallet::ACL::Krb5::Regex -- Wallet Kerberos v5 principal regex ACL verifier # # Written by Russ Allbery -# Copyright 2007, 2010 +# Copyright 2007, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::Krb5::Regex; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::ACL::Krb5; diff --git a/perl/lib/Wallet/ACL/LDAP/Attribute.pm b/perl/lib/Wallet/ACL/LDAP/Attribute.pm index aea8a72..c27729e 100644 --- a/perl/lib/Wallet/ACL/LDAP/Attribute.pm +++ b/perl/lib/Wallet/ACL/LDAP/Attribute.pm @@ -1,7 +1,7 @@ # Wallet::ACL::LDAP::Attribute -- Wallet LDAP attribute ACL verifier. # # Written by Russ Allbery -# Copyright 2012, 2013 +# Copyright 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::LDAP::Attribute; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Authen::SASL (); diff --git a/perl/lib/Wallet/ACL/NetDB.pm b/perl/lib/Wallet/ACL/NetDB.pm index b76d4ed..ad2164b 100644 --- a/perl/lib/Wallet/ACL/NetDB.pm +++ b/perl/lib/Wallet/ACL/NetDB.pm @@ -1,7 +1,7 @@ # Wallet::ACL::NetDB -- Wallet NetDB role ACL verifier. # # Written by Russ Allbery -# Copyright 2007, 2010 +# Copyright 2007, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::NetDB; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::ACL::Base; diff --git a/perl/lib/Wallet/ACL/NetDB/Root.pm b/perl/lib/Wallet/ACL/NetDB/Root.pm index 6c95c6e..34163e7 100644 --- a/perl/lib/Wallet/ACL/NetDB/Root.pm +++ b/perl/lib/Wallet/ACL/NetDB/Root.pm @@ -1,7 +1,7 @@ # Wallet::ACL::NetDB::Root -- Wallet NetDB role ACL verifier (root instances). # # Written by Russ Allbery -# Copyright 2007, 2010 +# Copyright 2007, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::NetDB::Root; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::ACL::NetDB; diff --git a/perl/lib/Wallet/Admin.pm b/perl/lib/Wallet/Admin.pm index 3a05284..d39c272 100644 --- a/perl/lib/Wallet/Admin.pm +++ b/perl/lib/Wallet/Admin.pm @@ -1,7 +1,7 @@ # Wallet::Admin -- Wallet system administrative interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2011, 2012, 2013 +# Copyright 2008, 2009, 2010, 2011, 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Admin; require 5.006; use strict; +use warnings; use vars qw($VERSION); use Wallet::ACL; diff --git a/perl/lib/Wallet/Config.pm b/perl/lib/Wallet/Config.pm index 5b0ab1c..527658c 100644 --- a/perl/lib/Wallet/Config.pm +++ b/perl/lib/Wallet/Config.pm @@ -10,6 +10,7 @@ package Wallet::Config; require 5.006; use strict; +use warnings; use vars qw($PATH $VERSION); # This version should be increased on any code change to this module. Always diff --git a/perl/lib/Wallet/Database.pm b/perl/lib/Wallet/Database.pm index 031be9e..3a4e130 100644 --- a/perl/lib/Wallet/Database.pm +++ b/perl/lib/Wallet/Database.pm @@ -6,7 +6,7 @@ # like DBIx::Class objects in the rest of the code. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2012, 2013 +# Copyright 2008, 2009, 2010, 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -19,6 +19,7 @@ package Wallet::Database; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::Schema; diff --git a/perl/lib/Wallet/Kadmin.pm b/perl/lib/Wallet/Kadmin.pm index 4ea7920..65a5700 100644 --- a/perl/lib/Wallet/Kadmin.pm +++ b/perl/lib/Wallet/Kadmin.pm @@ -1,7 +1,7 @@ # Wallet::Kadmin -- Kerberos administration API for wallet keytab backend. # # Written by Jon Robertson -# Copyright 2009, 2010 +# Copyright 2009, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Kadmin; require 5.006; use strict; +use warnings; use vars qw($VERSION); use Wallet::Config (); diff --git a/perl/lib/Wallet/Kadmin/Heimdal.pm b/perl/lib/Wallet/Kadmin/Heimdal.pm index 42de8e0..1208801 100644 --- a/perl/lib/Wallet/Kadmin/Heimdal.pm +++ b/perl/lib/Wallet/Kadmin/Heimdal.pm @@ -14,6 +14,7 @@ package Wallet::Kadmin::Heimdal; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Heimdal::Kadm5 qw(KRB5_KDB_DISALLOW_ALL_TIX); diff --git a/perl/lib/Wallet/Kadmin/MIT.pm b/perl/lib/Wallet/Kadmin/MIT.pm index 1ae01bf..ac45265 100644 --- a/perl/lib/Wallet/Kadmin/MIT.pm +++ b/perl/lib/Wallet/Kadmin/MIT.pm @@ -2,7 +2,7 @@ # # Written by Russ Allbery # Pulled into a module by Jon Robertson -# Copyright 2007, 2008, 2009, 2010 +# Copyright 2007, 2008, 2009, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -15,6 +15,7 @@ package Wallet::Kadmin::MIT; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::Config (); diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm index 8debac9..a009d76 100644 --- a/perl/lib/Wallet/Object/Base.pm +++ b/perl/lib/Wallet/Object/Base.pm @@ -1,7 +1,7 @@ # Wallet::Object::Base -- Parent class for any object stored in the wallet. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011 +# Copyright 2007, 2008, 2010, 2011, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Object::Base; require 5.006; use strict; +use warnings; use vars qw($VERSION); use DBI; diff --git a/perl/lib/Wallet/Object/Duo.pm b/perl/lib/Wallet/Object/Duo.pm index e5773c8..e3fe2da 100644 --- a/perl/lib/Wallet/Object/Duo.pm +++ b/perl/lib/Wallet/Object/Duo.pm @@ -14,6 +14,7 @@ package Wallet::Object::Duo; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use JSON; diff --git a/perl/lib/Wallet/Object/File.pm b/perl/lib/Wallet/Object/File.pm index 4afef04..1ff1288 100644 --- a/perl/lib/Wallet/Object/File.pm +++ b/perl/lib/Wallet/Object/File.pm @@ -1,7 +1,7 @@ # Wallet::Object::File -- File object implementation for the wallet. # # Written by Russ Allbery -# Copyright 2008, 2010 +# Copyright 2008, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Object::File; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Digest::MD5 qw(md5_hex); diff --git a/perl/lib/Wallet/Object/Keytab.pm b/perl/lib/Wallet/Object/Keytab.pm index 24c3302..975179b 100644 --- a/perl/lib/Wallet/Object/Keytab.pm +++ b/perl/lib/Wallet/Object/Keytab.pm @@ -1,7 +1,7 @@ # Wallet::Object::Keytab -- Keytab object implementation for the wallet. # # Written by Russ Allbery -# Copyright 2007, 2008, 2009, 2010, 2013 +# Copyright 2007, 2008, 2009, 2010, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Object::Keytab; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::Config (); diff --git a/perl/lib/Wallet/Object/WAKeyring.pm b/perl/lib/Wallet/Object/WAKeyring.pm index f8bd0f7..3e80300 100644 --- a/perl/lib/Wallet/Object/WAKeyring.pm +++ b/perl/lib/Wallet/Object/WAKeyring.pm @@ -1,7 +1,7 @@ # Wallet::Object::WAKeyring -- WebAuth keyring object implementation. # # Written by Russ Allbery -# Copyright 2012, 2013 +# Copyright 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Object::WAKeyring; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Digest::MD5 qw(md5_hex); diff --git a/perl/lib/Wallet/Report.pm b/perl/lib/Wallet/Report.pm index 1085546..bf48308 100644 --- a/perl/lib/Wallet/Report.pm +++ b/perl/lib/Wallet/Report.pm @@ -1,7 +1,7 @@ # Wallet::Report -- Wallet system reporting interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2013 +# Copyright 2008, 2009, 2010, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Report; require 5.006; use strict; +use warnings; use vars qw($VERSION); use Wallet::ACL; diff --git a/perl/lib/Wallet/Server.pm b/perl/lib/Wallet/Server.pm index 3266928..2765d34 100644 --- a/perl/lib/Wallet/Server.pm +++ b/perl/lib/Wallet/Server.pm @@ -1,7 +1,7 @@ # Wallet::Server -- Wallet system server implementation. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011, 2013 +# Copyright 2007, 2008, 2010, 2011, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Server; require 5.006; use strict; +use warnings; use vars qw(%MAPPING $VERSION); use Wallet::ACL; diff --git a/perl/t/data/perl.conf b/perl/t/data/perl.conf new file mode 100644 index 0000000..ca05568 --- /dev/null +++ b/perl/t/data/perl.conf @@ -0,0 +1,7 @@ +# Configuration for Perl tests. -*- perl -*- + +# Default minimum version requirement. +$MINIMUM_VERSION = '5.008'; + +# File must end with this line. +1; diff --git a/perl/t/general/acl.t b/perl/t/general/acl.t index e633f46..01b4801 100755 --- a/perl/t/general/acl.t +++ b/perl/t/general/acl.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the wallet ACL API. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use POSIX qw(strftime); use Test::More tests => 101; diff --git a/perl/t/general/admin.t b/perl/t/general/admin.t index 41bc33a..7c62932 100755 --- a/perl/t/general/admin.t +++ b/perl/t/general/admin.t @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 26; use Wallet::Admin; @@ -44,7 +47,7 @@ is ($admin->register_object ('base', 'Wallet::Object::Base'), 1, 'Registering Wallet::Object::Base works'); is ($admin->register_object ('base', 'Wallet::Object::Base'), undef, ' and cannot be registered twice'); -$server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; +my $server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; is ($@, '', 'Creating a server instance did not die'); is ($server->create ('base', 'service/admin'), 1, ' and creating base:service/admin succeeds'); @@ -83,7 +86,7 @@ SKIP: { is ($retval, 1, ' and performing an upgrade to 0.08 succeeds'); my $sql = "select version from dbix_class_schema_versions order by" . " version DESC"; - $version = $admin->dbh->selectall_arrayref ($sql); + my $version = $admin->dbh->selectall_arrayref ($sql); is (@$version, 2, ' and versions table has correct number of rows'); is (@{ $version->[0] }, 1, ' and correct number of columns'); is ($version->[0][0], '0.08', ' and the schema version is correct'); diff --git a/perl/t/general/config.t b/perl/t/general/config.t index 881f2bd..bc200de 100755 --- a/perl/t/general/config.t +++ b/perl/t/general/config.t @@ -1,13 +1,16 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the wallet server configuration. # # Written by Russ Allbery -# Copyright 2008, 2010 +# Copyright 2008, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 6; # Silence warnings since we're not using use. diff --git a/perl/t/general/init.t b/perl/t/general/init.t index b8ec3c9..58b9a4c 100755 --- a/perl/t/general/init.t +++ b/perl/t/general/init.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for database initialization. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 18; use Wallet::ACL; diff --git a/perl/t/general/report.t b/perl/t/general/report.t index 9563362..8d348ed 100755 --- a/perl/t/general/report.t +++ b/perl/t/general/report.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the wallet reporting interface. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 197; use Wallet::Admin; @@ -39,7 +42,7 @@ is ($acls[0][0], 1, ' and that is ACL ID 1'); is ($acls[0][1], 'ADMIN', ' with the right name'); # Create an object. -$server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; +my $server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; is ($@, '', 'Creating a server instance did not die'); is ($server->create ('base', 'service/admin'), 1, ' and creating base:service/admin succeeds'); diff --git a/perl/t/general/server.t b/perl/t/general/server.t index 9026439..0a527a5 100755 --- a/perl/t/general/server.t +++ b/perl/t/general/server.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the wallet server API. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 382; use POSIX qw(strftime); @@ -33,7 +36,7 @@ is ($@, '', 'Database initialization did not die'); is ($setup->reinitialize ($admin), 1, 'Database initialization succeeded'); # Now test the new method. -$server = eval { Wallet::Server->new (@trace) }; +my $server = eval { Wallet::Server->new (@trace) }; is ($@, '', 'Reopening with new did not die'); ok ($server->isa ('Wallet::Server'), ' and returned the right class'); my $schema = $server->schema; diff --git a/perl/t/lib/Util.pm b/perl/t/lib/Util.pm index 9e5b95e..187e483 100644 --- a/perl/t/lib/Util.pm +++ b/perl/t/lib/Util.pm @@ -1,7 +1,7 @@ # Utility class for wallet tests. # # Written by Russ Allbery -# Copyright 2007, 2008 +# Copyright 2007, 2008, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -10,6 +10,7 @@ package Util; require 5.006; use strict; +use warnings; use vars qw(@ISA @EXPORT $VERSION); use Wallet::Config; diff --git a/perl/t/object/base.t b/perl/t/object/base.t index 0432a23..11f18b7 100755 --- a/perl/t/object/base.t +++ b/perl/t/object/base.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the basic object implementation. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use POSIX qw(strftime); use Test::More tests => 137; diff --git a/perl/t/object/file.t b/perl/t/object/file.t index 0aecd9d..201f46d 100755 --- a/perl/t/object/file.t +++ b/perl/t/object/file.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the file object implementation. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use POSIX qw(strftime); use Test::More tests => 56; @@ -39,7 +42,7 @@ my $history = ''; my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); # Test error handling in the absence of configuration. -$object = eval { +my $object = eval { Wallet::Object::File->create ('file', 'test', $schema, @trace) }; ok (defined ($object), 'Creating a basic file object succeeds'); diff --git a/perl/t/object/keytab.t b/perl/t/object/keytab.t index 127762a..0f4a8b8 100755 --- a/perl/t/object/keytab.t +++ b/perl/t/object/keytab.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the keytab object implementation. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use POSIX qw(strftime); use Test::More tests => 141; @@ -117,7 +120,7 @@ sub enctypes { next unless /^ *\d+ /; my ($string) = /\((.*)\)\s*$/; next unless $string; - $enctype = $enctype{lc $string} || 'UNKNOWN'; + my $enctype = $enctype{lc $string} || 'UNKNOWN'; push (@enctypes, $enctype); } close KLIST; @@ -174,7 +177,7 @@ SKIP: { # Test that object creation without KEYTAB_TMP fails. undef $Wallet::Config::KEYTAB_TMP; - $object = eval { + my $object = eval { Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, @trace) }; @@ -634,7 +637,7 @@ EOO is ("@values", "@enctypes", ' and we get back the right enctype list'); my $eshow = join ("\n" . (' ' x 17), @enctypes); $eshow =~ s/\s+\z/\n/; - $expected = <<"EOO"; + my $expected = <<"EOO"; Type: keytab Name: wallet/one Enctypes: $eshow diff --git a/perl/t/style/minimum-version.t b/perl/t/style/minimum-version.t new file mode 100755 index 0000000..e4eeafd --- /dev/null +++ b/perl/t/style/minimum-version.t @@ -0,0 +1,47 @@ +#!/usr/bin/perl +# +# Check that too-new features of Perl are not being used. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at . +# +# Written by Russ Allbery +# Copyright 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this software and associated documentation files (the "Software"), +# to deal in the Software without restriction, including without limitation +# the rights to use, copy, modify, merge, publish, distribute, sublicense, +# and/or sell copies of the Software, and to permit persons to whom the +# Software is furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. + +use 5.006; +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::RRA qw(skip_unless_automated use_prereq); +use Test::RRA::Config qw($MINIMUM_VERSION); + +# Skip for normal user installs since this doesn't affect functionality. +skip_unless_automated('Minimum version tests'); + +# Load prerequisite modules. +use_prereq('Test::MinimumVersion'); + +# Check all files in the Perl distribution. +all_minimum_version_ok($MINIMUM_VERSION); diff --git a/perl/t/style/strict.t b/perl/t/style/strict.t new file mode 100755 index 0000000..7137b15 --- /dev/null +++ b/perl/t/style/strict.t @@ -0,0 +1,56 @@ +#!/usr/bin/perl +# +# Test Perl code for strict, warnings, and syntax. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at . +# +# Written by Russ Allbery +# Copyright 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this software and associated documentation files (the "Software"), +# to deal in the Software without restriction, including without limitation +# the rights to use, copy, modify, merge, publish, distribute, sublicense, +# and/or sell copies of the Software, and to permit persons to whom the +# Software is furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. + +use 5.006; +use strict; +use warnings; + +use lib 't/lib'; + +use File::Spec; +use Test::RRA qw(skip_unless_automated use_prereq); + +# Skip for normal user installs since this doesn't affect functionality. +skip_unless_automated('Strictness tests'); + +# Load prerequisite modules. +use_prereq('Test::Strict'); + +# Test everything in the distribution directory except the Build and +# Makefile.PL scripts generated by Module::Build. We also want to check use +# warnings. +$Test::Strict::TEST_SKIP = ['Build', 'Makefile.PL']; +$Test::Strict::TEST_WARNINGS = 1; +all_perl_files_ok(File::Spec->curdir); + +# Hack to suppress "used only once" warnings. +END { + $Test::Strict::TEST_SKIP = []; + $Test::Strict::TEST_WARNINGS = 0; +} diff --git a/perl/t/util/kadmin.t b/perl/t/util/kadmin.t index 8eabc6b..2a3d984 100755 --- a/perl/t/util/kadmin.t +++ b/perl/t/util/kadmin.t @@ -1,13 +1,16 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the kadmin object implementation. # # Written by Jon Robertson -# Copyright 2009, 2010, 2012, 2013 +# Copyright 2009, 2010, 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. +use strict; +use warnings; + use POSIX qw(strftime); use Test::More tests => 34; diff --git a/perl/t/verifier/basic.t b/perl/t/verifier/basic.t index 5697ae6..ce44d44 100755 --- a/perl/t/verifier/basic.t +++ b/perl/t/verifier/basic.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the basic wallet ACL verifiers. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 57; use Wallet::ACL::Base; diff --git a/perl/t/verifier/ldap-attr.t b/perl/t/verifier/ldap-attr.t index d8e416b..3c132e2 100755 --- a/perl/t/verifier/ldap-attr.t +++ b/perl/t/verifier/ldap-attr.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the LDAP attribute ACL verifier. # @@ -11,6 +11,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More; use lib 't/lib'; diff --git a/perl/t/verifier/netdb.t b/perl/t/verifier/netdb.t index d8fe561..7048ef9 100755 --- a/perl/t/verifier/netdb.t +++ b/perl/t/verifier/netdb.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the NetDB wallet ACL verifiers. # @@ -12,6 +12,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 5; use Wallet::ACL::NetDB; @@ -35,7 +38,7 @@ SKIP: { $Wallet::Config::NETDB_REMCTL_HOST = $netdb; # Finally, we can test. - $verifier = eval { Wallet::ACL::NetDB->new }; + my $verifier = eval { Wallet::ACL::NetDB->new }; ok (defined $verifier, ' and now creation succeeds'); is ($@, q{}, ' with no errors'); ok ($verifier->isa ('Wallet::ACL::NetDB'), ' and returns the right class'); diff --git a/server/keytab-backend b/server/keytab-backend index cf283bb..bd5a3f9 100755 --- a/server/keytab-backend +++ b/server/keytab-backend @@ -21,6 +21,7 @@ ############################################################################## use strict; +use warnings; use Sys::Syslog qw(openlog syslog); diff --git a/server/wallet-backend b/server/wallet-backend index 0b6a3fa..a97c8ce 100755 --- a/server/wallet-backend +++ b/server/wallet-backend @@ -7,6 +7,7 @@ ############################################################################## use strict; +use warnings; use Getopt::Long qw(GetOptions); use Sys::Syslog qw(openlog syslog); diff --git a/tests/TESTS b/tests/TESTS index 807d944..d947e97 100644 --- a/tests/TESTS +++ b/tests/TESTS @@ -4,6 +4,8 @@ client/prompt client/rekey docs/pod docs/pod-spelling +perl/minimum-version +perl/strict portable/asprintf portable/mkstemp portable/setenv diff --git a/tests/client/full-t.in b/tests/client/full-t.in index 9822b37..4861723 100644 --- a/tests/client/full-t.in +++ b/tests/client/full-t.in @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # End-to-end tests for the wallet client. # @@ -8,12 +8,14 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + # Point to our server configuration. This must be done before Wallet::Config # is loaded, and it's pulled in as a prerequisite for Wallet::Admin. BEGIN { $ENV{WALLET_CONFIG} = "$ENV{SOURCE}/data/wallet.conf" } -BEGIN { our $total = 59 } -use Test::More tests => $total; +use Test::More tests => 59; use lib "$ENV{SOURCE}/../perl/lib"; use Wallet::Admin; @@ -56,10 +58,10 @@ sub wallet { chdir "$ENV{SOURCE}" or die "Cannot chdir to $ENV{SOURCE}: $!\n"; SKIP: { - skip 'no keytab configuration', $total + skip 'no keytab configuration', 59 unless -f "$ENV{BUILD}/config/keytab"; my $remctld = '@REMCTLD@'; - skip 'remctld not found', $total unless $remctld; + skip 'remctld not found', 59 unless $remctld; # Spawn remctld and get local tickets. Don't destroy the user's Kerberos # ticket cache. diff --git a/tests/client/prompt-t.in b/tests/client/prompt-t.in index 8467411..686cc88 100644 --- a/tests/client/prompt-t.in +++ b/tests/client/prompt-t.in @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Password prompting tests for the wallet client. # @@ -8,8 +8,10 @@ # # See LICENSE for licensing terms. -BEGIN { our $total = 5 } -use Test::More tests => $total; +use strict; +use warnings; + +use Test::More tests => 5; use lib "$ENV{SOURCE}/../perl/lib"; use Wallet::Admin; @@ -21,12 +23,12 @@ use Util; chdir "$ENV{SOURCE}" or die "Cannot chdir to $ENV{SOURCE}: $!\n"; SKIP: { - skip 'no password configuration', $total + skip 'no password configuration', 5 unless -f "$ENV{BUILD}/config/password"; my $remctld = '@REMCTLD@'; - skip 'remctld not found', $total unless $remctld; + skip 'remctld not found', 5 unless $remctld; eval { require Expect }; - skip 'Expect module not found', $total if $@; + skip 'Expect module not found', 5 if $@; # Disable sending of wallet's output to our standard output. Do this # twice to avoid Perl warnings. diff --git a/tests/data/fake-kadmin b/tests/data/fake-kadmin index 57f9c97..ff90f88 100755 --- a/tests/data/fake-kadmin +++ b/tests/data/fake-kadmin @@ -1,13 +1,16 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Fake kadmin.local used to test the keytab backend. # # Written by Russ Allbery -# Copyright 2007 +# Copyright 2007, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. +use strict; +use warnings; + unless ($ARGV[0] eq '-q' && @ARGV == 2) { die "invalid arguments\n"; } diff --git a/tests/perl/minimum-version-t b/tests/perl/minimum-version-t new file mode 100755 index 0000000..8c49327 --- /dev/null +++ b/tests/perl/minimum-version-t @@ -0,0 +1,69 @@ +#!/usr/bin/perl +# +# Check that too-new features of Perl are not being used. +# +# This version of the check script supports mapping various directories to +# different version numbers. This allows a newer version of Perl to be +# required for internal tools than for public code. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at . +# +# Written by Russ Allbery +# Copyright 2012, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this software and associated documentation files (the "Software"), +# to deal in the Software without restriction, including without limitation +# the rights to use, copy, modify, merge, publish, distribute, sublicense, +# and/or sell copies of the Software, and to permit persons to whom the +# Software is furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. + +use 5.006; +use strict; +use warnings; + +use lib "$ENV{SOURCE}/tap/perl"; + +use Test::More; +use Test::RRA qw(skip_unless_automated use_prereq); +use Test::RRA::Automake qw(automake_setup perl_dirs); +use Test::RRA::Config qw($MINIMUM_VERSION %MINIMUM_VERSION); + +# Skip for normal user installs since this doesn't affect functionality. +skip_unless_automated('Minimum version tests'); + +# Load prerequisite modules. +use_prereq('Test::MinimumVersion'); + +# Set up Automake testing. +automake_setup(); + +# For each exception case in %MINIMUM_VERSION, check the files that should +# have that minium version. Sort for reproducible test order. Also +# accumulate the list of directories we've already tested. +my @tested; +for my $version (sort keys %MINIMUM_VERSION) { + my $paths_ref = $MINIMUM_VERSION{$version}; + all_minimum_version_ok($version, { paths => $paths_ref, no_plan => 1 }); + push(@tested, @{$paths_ref}); +} + +# Now, check anything that's left against the default minimum version. +my @paths = perl_dirs({ skip => [@tested] }); +all_minimum_version_ok($MINIMUM_VERSION, { paths => \@paths, no_plan => 1 }); + +# Tell the TAP harness that we're done. +done_testing(); diff --git a/tests/perl/strict-t b/tests/perl/strict-t new file mode 100755 index 0000000..2df6d58 --- /dev/null +++ b/tests/perl/strict-t @@ -0,0 +1,66 @@ +#!/usr/bin/perl +# +# Check Perl scripts for strict, warnings, and syntax. +# +# Checks all Perl scripts in the tree for problems uncovered by Test::Strict. +# This includes using strict and warnings for every script and ensuring they +# all pass a syntax check. Currently, test suite coverage is not checked. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at . +# +# Written by Russ Allbery +# Copyright 2012, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this software and associated documentation files (the "Software"), +# to deal in the Software without restriction, including without limitation +# the rights to use, copy, modify, merge, publish, distribute, sublicense, +# and/or sell copies of the Software, and to permit persons to whom the +# Software is furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. + +use 5.006; +use strict; +use warnings; + +use lib "$ENV{SOURCE}/tap/perl"; + +use Test::More; +use Test::RRA qw(skip_unless_automated use_prereq); +use Test::RRA::Automake qw(automake_setup perl_dirs); +use Test::RRA::Config qw(@STRICT_IGNORE @STRICT_PREREQ); + +# Skip for normal user installs since this doesn't affect functionality. +skip_unless_automated('Strictness tests'); + +# Load prerequisite modules. +use_prereq('Test::Strict'); + +# Check whether all prerequisites are available, and skip the test if any of +# them are not. +for my $module (@STRICT_PREREQ) { + use_prereq($module); +} + +# Set up Automake testing. This must be done after loading Test::Strict, +# since it wants to use FindBin to locate this script. +automake_setup(); + +# Run the actual tests. We also want to check warnings. +$Test::Strict::TEST_WARNINGS = 1; +all_perl_files_ok(perl_dirs({ skip => [@STRICT_IGNORE] })); + +# Suppress "used only once" warnings. +END { $Test::Strict::TEST_WARNINGS = 0 } -- cgit v1.2.3 From 6d7b65a912e6ea7e36d3ea5121bea2f427de453f Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 15 Jul 2014 16:50:13 -0700 Subject: Use DateTime objects in the database layer, not strings Pass in DateTime objects for the date fields in the database instead of formatted time strings. This provides better compatibility with different database engines. Document in README the need to install the DateTime::Format::* module corresponding to the DBD::* module used for the server database. Change-Id: Id25796da718d734ac96ca27ccea9045b0c80c03f Reviewed-on: https://gerrit.stanford.edu/1551 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- NEWS | 6 ++++++ README | 9 +++++---- perl/lib/Wallet/ACL.pm | 13 +++++++------ perl/lib/Wallet/Object/Base.pm | 28 ++++++++++++++-------------- 4 files changed, 32 insertions(+), 24 deletions(-) (limited to 'perl/lib/Wallet/Object/Base.pm') diff --git a/NEWS b/NEWS index 1594797..beddf7f 100644 --- a/NEWS +++ b/NEWS @@ -40,6 +40,12 @@ wallet 1.1 (unreleased) and an incorrect linkage in the schema for the ACL history, and add indices for the object type, name, and ACL instead. + Pass in DateTime objects for the date fields in the database instead + of formatted time strings. This provides better compatibility with + different database engines. Document in README the need to install + the DateTime::Format::* module corresponding to the DBD::* module used + for the server database. + The wallet server now requires Perl 5.8 or later (instead of 5.006 in previous versions) and is now built with Module::Build instead of ExtUtils::MakeMaker. This should be transparent to anyone not working diff --git a/README b/README index ef910bd..4c9f1d7 100644 --- a/README +++ b/README @@ -68,10 +68,11 @@ REQUIREMENTS plus Module::Build to build. It uses DBIx::Class and DBI to talk to a database, and therefore the DBIx::Class and DBI modules (and their dependencies) and a DBD module for the database it will use must be - installed. The SQL::Translator Perl module is also required for schema - deployment and database upgrades. If the wallet server is used with a - SQLite 3 database, the Perl module DateTime::Format::SQLite should also - be installed. + installed. The DateTime module is required for date handling, and the + SQL::Translator Perl module is also required for schema deployment and + database upgrades. You will also need the DateTime::Format::* module + corresponding to your DBD module (such as DateTime::Format::SQLite or + DateTime::Format::PG). Currently, the server has only been tested against SQLite 3, MySQL 5, and PostgreSQL, and prebuilt SQL files (for database upgrades) are only diff --git a/perl/lib/Wallet/ACL.pm b/perl/lib/Wallet/ACL.pm index 9507c64..57097c0 100644 --- a/perl/lib/Wallet/ACL.pm +++ b/perl/lib/Wallet/ACL.pm @@ -17,13 +17,13 @@ use strict; use warnings; use vars qw($VERSION); +use DateTime; use DBI; -use POSIX qw(strftime); # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.07'; +$VERSION = '0.08'; ############################################################################## # Constructors @@ -78,7 +78,7 @@ sub create { die "unable to retrieve new ACL ID" unless defined $id; # Add to the history table. - my $date = strftime ('%Y-%m-%d %T', localtime $time); + my $date = DateTime->from_epoch (epoch => $time); %record = (ah_acl => $id, ah_action => 'create', ah_by => $user, @@ -86,7 +86,6 @@ sub create { ah_on => $date); my $history = $schema->resultset('AclHistory')->create (\%record); die "unable to create new history entry" unless defined $history; - $guard->commit; }; if ($@) { @@ -164,13 +163,14 @@ sub log_acl { unless ($action =~ /^(add|remove)\z/) { die "invalid history action $action"; } + my $date = DateTime->from_epoch (epoch => $time); my %record = (ah_acl => $self->{id}, ah_action => $action, ah_scheme => $scheme, ah_identifier => $identifier, ah_by => $user, ah_from => $host, - ah_on => strftime ('%Y-%m-%d %T', localtime $time)); + ah_on => $date); $self->{schema}->resultset('AclHistory')->create (\%record); } @@ -242,11 +242,12 @@ sub destroy { $entry->delete if defined $entry; # Create new history line for the deletion. + my $date = DateTime->from_epoch (epoch => $time); my %record = (ah_acl => $self->{id}, ah_action => 'destroy', ah_by => $user, ah_from => $host, - ah_on => strftime ('%Y-%m-%d %T', localtime $time)); + ah_on => $date); $self->{schema}->resultset('AclHistory')->create (\%record); $guard->commit; }; diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm index a009d76..f1b8b72 100644 --- a/perl/lib/Wallet/Object/Base.pm +++ b/perl/lib/Wallet/Object/Base.pm @@ -17,15 +17,15 @@ use strict; use warnings; use vars qw($VERSION); +use DateTime; use DBI; -use POSIX qw(strftime); use Text::Wrap qw(wrap); use Wallet::ACL; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.06'; +$VERSION = '0.07'; ############################################################################## # Constructors @@ -63,22 +63,20 @@ sub create { die "invalid object name\n" unless $name; my $guard = $schema->txn_scope_guard; eval { + my $date = DateTime->from_epoch (epoch => $time); my %record = (ob_type => $type, ob_name => $name, ob_created_by => $user, ob_created_from => $host, - ob_created_on => strftime ('%Y-%m-%d %T', - localtime $time)); + ob_created_on => $date); $schema->resultset('Object')->create (\%record); - %record = (oh_type => $type, oh_name => $name, oh_action => 'create', oh_by => $user, oh_from => $host, - oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + oh_on => $date); $schema->resultset('ObjectHistory')->create (\%record); - $guard->commit; }; if ($@) { @@ -139,27 +137,27 @@ sub log_action { # assume that AutoCommit is turned off. my $guard = $self->{schema}->txn_scope_guard; eval { + my $date = DateTime->from_epoch (epoch => $time); my %record = (oh_type => $self->{type}, oh_name => $self->{name}, oh_action => $action, oh_by => $user, oh_from => $host, - oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + oh_on => $date); $self->{schema}->resultset('ObjectHistory')->create (\%record); + # Add in more timestamps based on the action type. my %search = (ob_type => $self->{type}, ob_name => $self->{name}); my $object = $self->{schema}->resultset('Object')->find (\%search); if ($action eq 'get') { $object->ob_downloaded_by ($user); $object->ob_downloaded_from ($host); - $object->ob_downloaded_on (strftime ('%Y-%m-%d %T', - localtime $time)); + $object->ob_downloaded_on ($date); } elsif ($action eq 'store') { $object->ob_stored_by ($user); $object->ob_stored_from ($host); - $object->ob_stored_on (strftime ('%Y-%m-%d %T', - localtime $time)); + $object->ob_stored_on ($date); } $object->update; $guard->commit; @@ -193,6 +191,7 @@ sub log_set { die "invalid history field $field"; } + my $date = DateTime->from_epoch (epoch => $time); my %record = (oh_type => $self->{type}, oh_name => $self->{name}, oh_action => 'set', @@ -202,7 +201,7 @@ sub log_set { oh_new => $new, oh_by => $user, oh_from => $host, - oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + oh_on => $date); $self->{schema}->resultset('ObjectHistory')->create (\%record); } @@ -703,12 +702,13 @@ sub destroy { $self->{schema}->resultset('Object')->search (\%search)->delete; # And create a new history object for the destroy action. + my $date = DateTime->from_epoch (epoch => $time); my %record = (oh_type => $type, oh_name => $name, oh_action => 'destroy', oh_by => $user, oh_from => $host, - oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + oh_on => $date); $self->{schema}->resultset('ObjectHistory')->create (\%record); $guard->commit; }; -- cgit v1.2.3 From c2112bf049d193c677335c94b477eb5cadb403ed Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 15 Jul 2014 20:46:57 -0700 Subject: Use DateTime objects uniformly, improve expires parsing Always use DateTime objects for every date field in the database, and translate them into the local time zone for display when pulling them out of the database. This should provide better portability to different database backends. Change the parsing of expires arguments to use Date::Parse, thus supporting a much broader variety of possible date and time formats and allowing easy conversion to a DateTime object. Document the new dependency. Change-Id: I2ee8eaa6aa6ae9925ac419e49234ec9880d4fe95 Reviewed-on: https://gerrit.stanford.edu/1555 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- NEWS | 4 ++++ README | 7 +++--- perl/lib/Wallet/ACL.pm | 5 ++-- perl/lib/Wallet/Object/Base.pm | 54 +++++++++++++++++++++++++++++------------- 4 files changed, 49 insertions(+), 21 deletions(-) (limited to 'perl/lib/Wallet/Object/Base.pm') diff --git a/NEWS b/NEWS index 08a7e14..d0ac4c3 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,10 @@ wallet 1.1 (unreleased) an existing wallet database, use wallet-admin to register the new object. + The date passed to expires can now be any date format understood by + Date::Parse, and Date::Parse (part of the TimeDate CPAN distribution) + is now a required prerequisite for the wallet server. + Fix wallet-rekey on keytabs containing multiple principals. Previous versions assumed one could concatenate keytab files together to make a valid keytab file, which doesn't work with some Kerberos libraries. diff --git a/README b/README index 4c9f1d7..f32ba15 100644 --- a/README +++ b/README @@ -68,9 +68,10 @@ REQUIREMENTS plus Module::Build to build. It uses DBIx::Class and DBI to talk to a database, and therefore the DBIx::Class and DBI modules (and their dependencies) and a DBD module for the database it will use must be - installed. The DateTime module is required for date handling, and the - SQL::Translator Perl module is also required for schema deployment and - database upgrades. You will also need the DateTime::Format::* module + installed. The Date::Parse (part of the TimeDate distribution) and + DateTime modules are required for date handling, and the SQL::Translator + Perl module is also required for schema deployment and database + upgrades. You will also need the DateTime::Format::* module corresponding to your DBD module (such as DateTime::Format::SQLite or DateTime::Format::PG). diff --git a/perl/lib/Wallet/ACL.pm b/perl/lib/Wallet/ACL.pm index b488b43..a3b0146 100644 --- a/perl/lib/Wallet/ACL.pm +++ b/perl/lib/Wallet/ACL.pm @@ -378,8 +378,9 @@ sub history { my @data = $self->{schema}->resultset('AclHistory') ->search (\%search, \%options); for my $data (@data) { - $output .= sprintf ("%s %s ", $data->ah_on->ymd, - $data->ah_on->hms); + my $date = $data->ah_on; + $date->set_time_zone ('local'); + $output .= sprintf ("%s %s ", $date->ymd, $date->hms); if ($data->ah_action eq 'add' || $data->ah_action eq 'remove') { $output .= sprintf ("%s %s %s", $data->ah_action, $data->ah_scheme, $data->ah_identifier); diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm index f1b8b72..4939bf5 100644 --- a/perl/lib/Wallet/Object/Base.pm +++ b/perl/lib/Wallet/Object/Base.pm @@ -18,6 +18,7 @@ use warnings; use vars qw($VERSION); use DateTime; +use Date::Parse qw(str2time); use DBI; use Text::Wrap qw(wrap); use Wallet::ACL; @@ -230,10 +231,20 @@ sub _set_internal { my %search = (ob_type => $type, ob_name => $name); my $object = $self->{schema}->resultset('Object')->find (\%search); - my $old = $object->get_column ("ob_$attr"); - - $object->update ({ "ob_$attr" => $value }); - $self->log_set ($attr, $old, $value, $user, $host, $time); + my $column = "ob_$attr"; + my $old = $object->$column; + my $new = $value; + $object->update ({ $column => $value }); + + if (ref ($old) && $old->isa ('DateTime')) { + $old->set_time_zone ('local'); + $old = $old->ymd . q{ } . $old->hms; + } + if (ref ($new) && $new->isa ('DateTime')) { + $new->set_time_zone ('local'); + $new = $new->ymd . q{ } . $new->hms; + } + $self->log_set ($attr, $old, $new, $user, $host, $time); $guard->commit; }; if ($@) { @@ -262,7 +273,7 @@ sub _get_internal { my %search = (ob_type => $type, ob_name => $name); my $object = $self->{schema}->resultset('Object')->find (\%search); - $value = $object->get_column ($attr); + $value = $object->$attr; }; if ($@) { $self->error ($@); @@ -334,15 +345,23 @@ sub comment { sub expires { my ($self, $expires, $user, $host, $time) = @_; if ($expires) { - if ($expires !~ /^\d{4}-\d\d-\d\d( \d\d:\d\d:\d\d)?\z/) { + my $seconds = str2time ($expires); + unless (defined $seconds) { $self->error ("malformed expiration time $expires"); return; } - return $self->_set_internal ('expires', $expires, $user, $host, $time); + my $date = DateTime->from_epoch (epoch => $seconds); + return $self->_set_internal ('expires', $date, $user, $host, $time); } elsif (defined $expires) { return $self->_set_internal ('expires', undef, $user, $host, $time); } else { - return $self->_get_internal ('expires'); + my $date = $self->_get_internal ('expires'); + if (defined $date) { + $date->set_time_zone ('local'); + return $date->ymd . q{ } . $date->hms; + } else { + return; + } } } @@ -506,13 +525,14 @@ sub history { eval { my %search = (oh_type => $self->{type}, oh_name => $self->{name}); - my %attrs = (order_by => 'oh_on'); + my %attrs = (order_by => 'oh_id'); my @history = $self->{schema}->resultset('ObjectHistory') ->search (\%search, \%attrs); for my $history_rs (@history) { - $output .= sprintf ("%s %s ", $history_rs->oh_on->ymd, - $history_rs->oh_on->hms); + my $date = $history_rs->oh_on; + $date->set_time_zone ('local'); + $output .= sprintf ("%s %s ", $date->ymd, $date->hms); my $old = $history_rs->oh_old; my $new = $history_rs->oh_new; @@ -635,15 +655,15 @@ sub show { for my $i (0 .. $#attrs) { my $field = $attrs[$i][0]; my $fieldtext = $attrs[$i][1]; - next unless my $value = $object_rs->get_column ($field); + my $value = $object_rs->$field; + next unless defined($value); if ($field eq 'ob_comment' && length ($value) > 79 - 17) { local $Text::Wrap::columns = 80; local $Text::Wrap::unexpand = 0; $value = wrap (' ' x 17, ' ' x 17, $value); $value =~ s/^ {17}//; - } - if ($field eq 'ob_created_by') { + } elsif ($field eq 'ob_created_by') { my @flags = $self->flag_list; if (not @flags and $self->error) { return; @@ -656,8 +676,10 @@ sub show { return; } $output .= $attr_output; - } - if ($field =~ /^ob_(owner|acl_)/) { + } elsif (ref ($value) && $value->isa ('DateTime')) { + $value->set_time_zone ('local'); + $value = sprintf ("%s %s", $value->ymd, $value->hms); + } elsif ($field =~ /^ob_(owner|acl_)/) { my $acl = eval { Wallet::ACL->new ($value, $self->{schema}) }; if ($acl and not $@) { $value = $acl->name || $value; -- cgit v1.2.3 From 5d0038202d82c71119fefa9c5bd0f816ae55991c Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 15 Jul 2014 22:57:31 -0700 Subject: Return the name of the ACL instead of the numeric ID The owner and getacl commands now return the current name of the ACL instead of its numeric ID, matching the documentation of owner. Change-Id: Ic47aad48bd1454ed4bffff7030b0492d74eee4fa Reviewed-on: https://gerrit.stanford.edu/1559 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- NEWS | 3 +++ perl/lib/Wallet/Object/Base.pm | 20 +++++++++++++++++--- perl/lib/Wallet/Server.pm | 8 ++++---- perl/t/object/base.t | 12 ++++++------ 4 files changed, 30 insertions(+), 13 deletions(-) (limited to 'perl/lib/Wallet/Object/Base.pm') diff --git a/NEWS b/NEWS index 40efd3a..7108454 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,9 @@ wallet 1.1 (unreleased) an existing wallet database, use wallet-admin to register the new object. + The owner and getacl commands now return the current name of the ACL + instead of its numeric ID, matching the documentation of owner. + The date passed to expires can now be any date format understood by Date::Parse, and Date::Parse (part of the TimeDate CPAN distribution) is now a required prerequisite for the wallet server. diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm index 4939bf5..a6a78bf 100644 --- a/perl/lib/Wallet/Object/Base.pm +++ b/perl/lib/Wallet/Object/Base.pm @@ -26,7 +26,7 @@ use Wallet::ACL; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.07'; +$VERSION = '0.08'; ############################################################################## # Constructors @@ -302,7 +302,14 @@ sub acl { } elsif (defined $id) { return $self->_set_internal ($attr, undef, $user, $host, $time); } else { - return $self->_get_internal ($attr); + my $id = $self->_get_internal ($attr); + return unless defined $id; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + return $acl->name; } } @@ -380,7 +387,14 @@ sub owner { } elsif (defined $owner) { return $self->_set_internal ('owner', undef, $user, $host, $time); } else { - return $self->_get_internal ('owner'); + my $id = $self->_get_internal ('owner'); + return unless defined $id; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + return $acl->name; } } diff --git a/perl/lib/Wallet/Server.pm b/perl/lib/Wallet/Server.pm index e278489..95fd4e6 100644 --- a/perl/lib/Wallet/Server.pm +++ b/perl/lib/Wallet/Server.pm @@ -831,7 +831,7 @@ failure to get the error message. Gets or sets the ACL type ACL to ID for the object identified by TYPE and NAME. ACL should be one of C, C, C, C, or C. If ID is not given, returns the current setting of that ACL as -a numeric ACL ID or undef if that ACL isn't set or on failure. To +the name of the ACL or undef if that ACL isn't set or on failure. To distinguish between an ACL that isn't set and a failure to retrieve the ACL, the caller should call error() after an undef return. If error() also returns undef, that ACL wasn't set; otherwise, error() will return @@ -1041,9 +1041,9 @@ owner ACL will not be checked. =item owner(TYPE, NAME [, OWNER]) Gets or sets the owner for the object identified by TYPE and NAME. If -OWNER is not given, returns the current owner as a numeric ACL ID or undef -if no owner is set or on an error. To distinguish between an owner that -isn't set and a failure to retrieve the owner, the caller should call +OWNER is not given, returns the current owner as the name of the ACL or +undef if no owner is set or on an error. To distinguish between an owner +that isn't set and a failure to retrieve the owner, the caller should call error() after an undef return. If error() also returns undef, that ACL wasn't set; otherwise, error() will return the error message. diff --git a/perl/t/object/base.t b/perl/t/object/base.t index 11f18b7..ee9ff4b 100755 --- a/perl/t/object/base.t +++ b/perl/t/object/base.t @@ -70,7 +70,7 @@ if ($object->owner ('ADMIN', @trace)) { } else { is ($object->error, '', ' and setting it to ADMIN works'); } -is ($object->owner, $acl->id, ' at which point it is ADMIN'); +is ($object->owner, $acl->name, ' at which point it is ADMIN'); ok (! $object->owner ('unknown', @trace), ' but setting it to something bogus fails'); is ($object->error, 'ACL unknown not found', ' with the right error'); @@ -128,7 +128,7 @@ for my $type (qw/get store show destroy flags/) { } else { is ($object->error, '', ' and setting it to ADMIN (numeric) works'); } - is ($object->acl ($type), $acl->id, ' at which point it is ADMIN'); + is ($object->acl ($type), $acl->name, ' at which point it is ADMIN'); ok (! $object->acl ($type, 22, @trace), ' but setting it to something bogus fails'); is ($object->error, 'ACL 22 not found', ' with the right error'); @@ -138,8 +138,8 @@ for my $type (qw/get store show destroy flags/) { is ($object->error, '', ' and clearing it works'); } is ($object->acl ($type), undef, ' at which point it is cleared'); - is ($object->acl ($type, $acl->id, @trace), 1, - ' and setting it again works'); + is ($object->acl ($type, $acl->name, @trace), 1, + ' and setting it again by name works'); } # Flags. @@ -189,7 +189,7 @@ is ($object->error, "cannot store keytab:${princ}: object is locked", is ($object->owner ('', @trace), undef, ' and setting owner fails'); is ($object->error, "cannot modify keytab:${princ}: object is locked", ' for the same reason'); -is ($object->owner, 1, ' but retrieving the owner works'); +is ($object->owner, 'ADMIN', ' but retrieving the owner works'); is ($object->expires ('', @trace), undef, ' and setting expires fails'); is ($object->error, "cannot modify keytab:${princ}: object is locked", ' for the same reason'); @@ -198,7 +198,7 @@ for my $acl (qw/get store show destroy flags/) { is ($object->acl ($acl, '', @trace), undef, " and setting $acl ACL fails"); is ($object->error, "cannot modify keytab:${princ}: object is locked", ' for the same reason'); - is ($object->acl ($acl), 1, " but retrieving $acl ACL works"); + is ($object->acl ($acl), 'ADMIN', " but retrieving $acl ACL works"); } is ($object->flag_check ('locked'), 1, ' and checking flags works'); @flags = $object->flag_list; -- cgit v1.2.3