Commit 92f83e48 authored by Leigh Stoller's avatar Leigh Stoller

Work on an optimization to the perl code. Maybe you have noticed, but

starting any one of our scripts can take a second or two. That time is
spent including and compiling 10000s of thousands of lines of perl
code, both from our libraries and from the perl libraries.

Mostly this is just a maintenance thing; we just never thought about
it much and we have a lot more code these days.

So I have done two things.

1) I have used SelfLoader() on some of our biggest perl modules.
   SelfLoader delays compilation until code is used. This is not as
   good as AutoLoader() though, and so I did it with just a few 
   modules (the biggest ones).

2) Mostly I reorganized things:

  a) Split libdb into an EmulabConstants module and all the rest of
     the code, which is slowly getting phased out.

  b) Move little things around to avoid including libdb or Experiment
     (the biggest files).

  c) Change "use foo" in many places to a "require foo" in the
     function that actually uses that module. This was really a big
     win cause we have dozens of cases where we would include a
     module, but use it in only one place and typically not all.

Most things are now starting up in 1/3 the time. I am hoping this will
help to reduce the load spiking we see on boss, and also help with the
upcoming Geni tutorial (which kill boss last time).
parent d8230a46
......@@ -14,7 +14,6 @@ use vars qw(@ISA @EXPORT);
@EXPORT = qw ( );
# Must come after package declaration!
use lib '@prefix@/lib';
use libdb;
use libtestbed;
use Project;
......
This diff is collapsed.
This diff is collapsed.
#!/usr/bin/perl -w
#
# EMULAB-COPYRIGHT
# Copyright (c) 2009 University of Utah and the Flux Group.
# Copyright (c) 2009, 2010 University of Utah and the Flux Group.
# All rights reserved.
#
......@@ -33,7 +33,6 @@ sub FWTEARDOWN() { return 4; }
my $cnetstack = "-S Control";
my $cnetvlanname = "Control";
use lib '@prefix@/lib';
use emdbi;
use libdb;
use libtestbed;
......
#
# EMULAB-COPYRIGHT
# Copyright (c) 2000-2009 University of Utah and the Flux Group.
# Copyright (c) 2000-2010 University of Utah and the Flux Group.
# All rights reserved.
#
SRCDIR = @srcdir@
......@@ -29,7 +29,8 @@ LIBEXEC_SCRIPTS = $(WEB_BIN_SCRIPTS) $(WEB_SBIN_SCRIPTS) xmlconvert
LIB_SCRIPTS = libdb.pm Node.pm libdb.py libadminctrl.pm Experiment.pm \
NodeType.pm Interface.pm User.pm Group.pm Project.pm \
Image.pm OSinfo.pm Archive.pm Logfile.pm Lan.pm emdbi.pm \
emdb.pm emutil.pm Firewall.pm VirtExperiment.pm libGeni.pm
emdb.pm emutil.pm Firewall.pm VirtExperiment.pm libGeni.pm \
libEmulab.pm EmulabConstants.pm TraceUse.pm
# Stuff installed on plastic.
USERSBINS = genelists.proxy dumperrorlog.proxy backup
......
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2005-2009 University of Utah and the Flux Group.
# Copyright (c) 2005-2010 University of Utah and the Flux Group.
# All rights reserved.
#
package Group;
......@@ -665,7 +665,7 @@ sub Trust($$)
#
# User must be active to be trusted.
#
return PROJMEMBERTRUST_NONE
return PROJMEMBERTRUST_NONE()
if ($user->status() ne USERSTATUS_ACTIVE());
#
......@@ -676,7 +676,7 @@ sub Trust($$)
#
# No membership is the same as no trust. True? Maybe an error instead?
#
return PROJMEMBERTRUST_NONE
return PROJMEMBERTRUST_NONE()
if (!defined($membership));
return TBTrustConvert($membership->trust());
......@@ -698,57 +698,55 @@ sub AccessCheck($$$)
my $gid = $self->gid();
my $uid = $user->uid();
if ($access_type < TB_PROJECT_MIN ||
$access_type > TB_PROJECT_MAX) {
if ($access_type < TB_PROJECT_MIN() ||
$access_type > TB_PROJECT_MAX()) {
print "*** Invalid access type: $access_type!\n";
return 0;
}
# Admins do whatever they want. Treat leadgroup special though since
# the user has to actually be a member of the project, not just an admin.
return 1
if ($user->IsAdmin() && $access_type != TB_PROJECT_LEADGROUP);
if ($user->IsAdmin() && $access_type != TB_PROJECT_LEADGROUP());
if ($access_type == TB_PROJECT_READINFO) {
$mintrust = PROJMEMBERTRUST_USER;
if ($access_type == TB_PROJECT_READINFO()) {
$mintrust = PROJMEMBERTRUST_USER();
}
elsif ($access_type == TB_PROJECT_MAKEGROUP ||
$access_type == TB_PROJECT_DELGROUP) {
$mintrust = PROJMEMBERTRUST_GROUPROOT;
elsif ($access_type == TB_PROJECT_MAKEGROUP() ||
$access_type == TB_PROJECT_DELGROUP()) {
$mintrust = PROJMEMBERTRUST_GROUPROOT();
}
elsif ($access_type == TB_PROJECT_LEADGROUP) {
elsif ($access_type == TB_PROJECT_LEADGROUP()) {
#
# Allow mere user (in default group) to lead a subgroup.
#
$mintrust = PROJMEMBERTRUST_USER;
$mintrust = PROJMEMBERTRUST_USER();
}
elsif ($access_type == TB_PROJECT_MAKEOSID ||
$access_type == TB_PROJECT_MAKEIMAGEID ||
$access_type == TB_PROJECT_CREATEEXPT) {
$mintrust = PROJMEMBERTRUST_LOCALROOT;
elsif ($access_type == TB_PROJECT_MAKEOSID() ||
$access_type == TB_PROJECT_MAKEIMAGEID() ||
$access_type == TB_PROJECT_CREATEEXPT()) {
$mintrust = PROJMEMBERTRUST_LOCALROOT();
}
elsif ($access_type == TB_PROJECT_ADDUSER ||
$access_type == TB_PROJECT_EDITGROUP) {
elsif ($access_type == TB_PROJECT_ADDUSER() ||
$access_type == TB_PROJECT_EDITGROUP()) {
#
# If user is project_root or group_root in default group,
# allow them to add/edit/remove users in any group.
#
if (TBMinTrust(TBGrpTrust($uid, $pid, $pid),
PROJMEMBERTRUST_GROUPROOT)) {
if (TBMinTrust($self->Trust($user), PROJMEMBERTRUST_GROUPROOT())) {
return 1;
}
#
# Otherwise, editing a group requires group_root
# in that group.
#
$mintrust = PROJMEMBERTRUST_GROUPROOT;
$mintrust = PROJMEMBERTRUST_GROUPROOT();
}
elsif ($access_type == TB_PROJECT_BESTOWGROUPROOT) {
elsif ($access_type == TB_PROJECT_BESTOWGROUPROOT()) {
#
# If user is project_root,
# allow them to bestow group_root in any group.
#
if (TBMinTrust(TBGrpTrust($uid, $pid, $pid),
PROJMEMBERTRUST_PROJROOT)) {
if (TBMinTrust($self->Trust($user), PROJMEMBERTRUST_PROJROOT())) {
return 1;
}
......@@ -765,8 +763,7 @@ sub AccessCheck($$$)
# Non-default group.
# group_root in default group may bestow group_root.
#
if (TBMinTrust(TBGrpTrust($uid, $pid, $pid),
PROJMEMBERTRUST_GROUPROOT)) {
if (TBMinTrust($self->Trust($user), PROJMEMBERTRUST_GROUPROOT())) {
return 1;
}
......@@ -774,10 +771,10 @@ sub AccessCheck($$$)
# group_root in the group in question may also bestow
# group_root.
#
$mintrust = PROJMEMBERTRUST_GROUPROOT;
$mintrust = PROJMEMBERTRUST_GROUPROOT();
}
}
elsif ($access_type == TB_PROJECT_GROUPGRABUSERS) {
elsif ($access_type == TB_PROJECT_GROUPGRABUSERS()) {
#
# Only project_root or group_root in default group
# may grab (involuntarily add) users into groups.
......@@ -785,10 +782,10 @@ sub AccessCheck($$$)
if (! $self->IsProjectGroup()) {
return $self->GetProject()->AccessCheck($user, $access_type);
}
$mintrust = PROJMEMBERTRUST_GROUPROOT;
$mintrust = PROJMEMBERTRUST_GROUPROOT();
}
elsif ($access_type == TB_PROJECT_DELUSER) {
$mintrust = PROJMEMBERTRUST_PROJROOT;
elsif ($access_type == TB_PROJECT_DELUSER()) {
$mintrust = PROJMEMBERTRUST_PROJROOT();
}
else {
print "*** Invalid access type: $access_type!\n";
......@@ -1264,7 +1261,7 @@ sub UpdateStats($$$$$)
" allexpt_pnode_duration+($pnodes * ${duration}) ".
"where gid_idx='$gid_idx'");
if ($mode eq TBDB_STATS_SWAPIN || $mode eq TBDB_STATS_START) {
if ($mode eq TBDB_STATS_SWAPIN() || $mode eq TBDB_STATS_START()) {
DBQueryWarn("update groups set ".
" expt_last=now(),expt_count=expt_count+1 ".
"where gid_idx='$gid_idx'");
......
......@@ -14,13 +14,8 @@ use vars qw(@ISA @EXPORT);
@EXPORT = qw ( );
# Must come after package declaration!
use lib '@prefix@/lib';
use libdb;
use libtestbed;
use Project;
use Group;
use User;
use OSinfo;
use English;
use Data::Dumper;
use overload ('""' => 'Stringify');
......@@ -173,6 +168,7 @@ sub Create($$$$$$$$)
{
my ($class, $project, $group, $creator,
$imagename, $imageid, $argref, $usrerr_ref) = @_;
require OSinfo;
return undef
if (ref($class) || !ref($project));
......@@ -505,6 +501,7 @@ sub Update($$)
sub GetProject($)
{
my ($self) = @_;
require Project;
# Must be a real reference.
return undef
......@@ -525,6 +522,7 @@ sub GetProject($)
sub GetGroup($)
{
my ($self) = @_;
require Group;
# Must be a real reference.
return undef
......
......@@ -14,11 +14,9 @@ use vars qw(@ISA @EXPORT);
@EXPORT = qw ( );
# Must come after package declaration!
use lib '@prefix@/lib';
use libdb;
use libtestbed;
use Node;
use Experiment;
use English;
use Data::Dumper;
use overload ('""' => 'Stringify');
......@@ -702,6 +700,7 @@ sub SetRole($$)
sub GetExperiment($)
{
my ($self) = @_;
require Experiment;
return -1
if (!ref($self));
......@@ -939,6 +938,7 @@ sub Initialize($)
my %delays = ();
my %elabinelab = ();
my %vinterfaces= ();
require Experiment;
# Prevent vlan insertion above.
$initialize = 1;
......
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2007 University of Utah and the Flux Group.
# Copyright (c) 2007-2010 University of Utah and the Flux Group.
# All rights reserved.
#
package Logfile;
......@@ -14,11 +14,9 @@ use vars qw(@ISA @EXPORT);
@EXPORT = qw ( );
# Must come after package declaration!
use lib '@prefix@/lib';
use libdb;
use libtestbed;
use English;
use Group;
use Data::Dumper;
# Configure variables
......@@ -146,6 +144,7 @@ sub Delete($;$)
sub AccessCheck($$)
{
my ($self, $user) = @_;
require Group;
# Must be a real reference.
return 0
......
This diff is collapsed.
......@@ -14,12 +14,8 @@ use vars qw(@ISA @EXPORT);
@EXPORT = qw ( );
# Must come after package declaration!
use lib '@prefix@/lib';
use libdb;
use libtestbed;
use Project;
use User;
use Image;
use English;
use Data::Dumper;
use overload ('""' => 'Stringify');
......@@ -343,6 +339,7 @@ sub Update($$)
sub GetProject($)
{
my ($self) = @_;
require Project;
# Must be a real reference.
return undef
......@@ -650,6 +647,7 @@ sub RunsOnParent($$)
sub MapToImage($$)
{
my ($self, $type) = @_;
require Image;
if (ref($type)) {
$type = $type->type();
......
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2005-2009 University of Utah and the Flux Group.
# Copyright (c) 2005-2010 University of Utah and the Flux Group.
# All rights reserved.
#
package Project;
......@@ -299,12 +299,12 @@ sub Trust($$)
my ($self, $user) = @_;
# Must be a real reference.
return PROJMEMBERTRUST_NONE
return PROJMEMBERTRUST_NONE()
if (! ref($self));
my $group = $self->GetProjectGroup();
# Should not happen!
return PROJMEMBERTRUST_NONE
return PROJMEMBERTRUST_NONE()
if (!defined($group));
return $group->Trust($user);
......@@ -634,7 +634,7 @@ sub UpdateStats($$$$$)
" allexpt_pnode_duration+($pnodes * ${duration}) ".
"where pid_idx='$pid_idx'");
if ($mode eq TBDB_STATS_SWAPIN || $mode eq TBDB_STATS_START) {
if ($mode eq TBDB_STATS_SWAPIN() || $mode eq TBDB_STATS_START()) {
DBQueryWarn("update projects set ".
" expt_last=now(),expt_count=expt_count+1 ".
"where pid_idx='$pid_idx'");
......
......@@ -11,13 +11,13 @@ use Exporter;
use vars qw(@ISA);
@ISA = "Exporter";
use libdb;
use emdb;
use EmulabConstants;
use libtestbed;
use English;
use Data::Dumper;
use File::Basename;
use overload ('""' => 'Stringify');
use Project;
use vars qw($NEWUSER_FLAGS_PROJLEADER $NEWUSER_FLAGS_WIKIONLY
$NEWUSER_FLAGS_WEBONLY $NEWUSER_FLAGS_ARCHIVED
$NEWUSER_FLAGS_NOUUID
......@@ -640,6 +640,7 @@ sub ImpliedUser($)
sub IsOpsGuy($)
{
my ($self) = @_;
require Group;
return 0
if (! ref($self));
......@@ -648,8 +649,12 @@ sub IsOpsGuy($)
print STDERR "*** IsOpsGuy: Must be invoked on current user!\n";
return 0;
}
return TBMinTrust(TBProjTrust($self->uid_idx(), TBOPSPID()),
PROJMEMBERTRUST_USER());
my $group = Group->Lookup(TBOPSPID(), TBOPSPID());
if (!defined($group)) {
print STDERR "*** IsOpsGuy: No emulab-ops project!\n";
return 0;
}
return TBMinTrust($group->Trust($self), PROJMEMBERTRUST_USER());
}
#
......@@ -966,6 +971,7 @@ sub SameUser($$)
sub FirstApprovedProject($$)
{
my ($self, $pptr) = @_;
require Project;
# Must be a real reference.
return -1
......@@ -1188,6 +1194,7 @@ sub SetUserInterface($$)
sub SendVerifiedEmail($)
{
my ($self) = @_;
require Group;
# Must be a real reference.
return -1
......@@ -1249,6 +1256,7 @@ sub SendVerifiedEmail($)
sub GroupMembershipList($$;$)
{
my ($self, $prval, $desired_trust) = @_;
require Group;
# Must be a real reference.
return -1
......@@ -1296,6 +1304,8 @@ sub GroupMembershipList($$;$)
sub ProjectMembershipList($$;$)
{
my ($self, $prval, $desired_trust) = @_;
require Project;
require Group;
# Must be a real reference.
return -1
......@@ -1344,6 +1354,7 @@ sub ProjectMembershipList($$;$)
sub ProjectLeaderList($$;$)
{
my ($self, $prval) = @_;
require Project;
# Must be a real reference.
return -1
......@@ -1524,7 +1535,7 @@ sub AccessCheck($$$)
my $mintrust;
if ($access_type < TB_USERINFO_MIN || $access_type > TB_USERINFO_MAX) {
if ($access_type < TB_USERINFO_MIN() || $access_type > TB_USERINFO_MAX()) {
print "*** Invalid access type $access_type!\n";
return 0;
}
......@@ -1542,7 +1553,7 @@ sub AccessCheck($$$)
#
# Only project leader in same project as user.
#
if ($access_type == TB_USERINFO_MODIFYINFO) {
if ($access_type == TB_USERINFO_MODIFYINFO()) {
#
# This join will allow the operation if the current user is in the
# same project (any project) as the target user, but with root permissions.
......@@ -1589,7 +1600,6 @@ sub escapeshellarg($)
#
package User::NonLocal;
use User;
use libdb;
use libtestbed;
use English;
use overload ('""' => 'Stringify');
......
......@@ -14,7 +14,6 @@ use vars qw(@ISA @EXPORT);
@EXPORT = qw ( );
# Must come after package declaration!
use lib '@prefix@/lib';
use emdb;
use emutil;
use libtestbed;
......@@ -304,7 +303,8 @@ sub Store($;$)
else {
# Sanity check the fields.
if (TBcheck_dbslot($val, "experiments", $key,
TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
TBDB_CHECKDBSLOT_WARN()|
TBDB_CHECKDBSLOT_ERROR())) {
$val = DBQuoteSpecial($val);
push(@setlist, "$key=$val");
......@@ -949,7 +949,8 @@ sub Store($;$)
else {
# Sanity check the fields.
if (TBcheck_dbslot($val, $tablename, $key,
TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
TBDB_CHECKDBSLOT_WARN()|
TBDB_CHECKDBSLOT_ERROR())) {
push(@values, DBQuoteSpecial($val));
}
else {
......
......@@ -9,37 +9,34 @@
package emutil;
use strict;
use Exporter;
use SelfLoader;
use vars qw(@ISA @EXPORT);
@ISA = "Exporter";
@EXPORT = qw (TBDB_CHECKDBSLOT_NOFLAGS TBDB_CHECKDBSLOT_WARN
TBDB_CHECKDBSLOT_ERROR TBcheck_dbslot TBFieldErrorString
TBGetUniqueIndex ParRun NoLogins);
@ISA = qw(Exporter SelfLoader);
@EXPORT = qw(TBDB_CHECKDBSLOT_NOFLAGS TBDB_CHECKDBSLOT_WARN
TBDB_CHECKDBSLOT_ERROR TBcheck_dbslot TBFieldErrorString
TBGetUniqueIndex ParRun);
use emdb;
use English;
# Configure variables
my $TB = "@prefix@";
my $TBOPS = "@TBOPSEMAIL@";
my $BOSSNODE = "@BOSSNODE@";
my $EVENTSYS = "@EVENTSYS@";
#
# Support for checking field values against what is specified.
#
use vars qw(%DBFieldData $DBFieldErrstr);
if ($EVENTSYS) {
require event;
import event;
}
%DBFieldData = ();
$DBFieldErrstr = "";
# _Always_ make sure that this 1 is at the end of the file...
1;
__DATA__
# Constants for checkslot code.
sub TBDB_CHECKDBSLOT_NOFLAGS() { 0x0; }
sub TBDB_CHECKDBSLOT_WARN() { 0x1; }
sub TBDB_CHECKDBSLOT_ERROR() { 0x2; }
#
# Support for checking field values against what is specified.
#
my %DBFieldData;
my $DBFieldErrstr = "";
sub TBFieldErrorString() { return $DBFieldErrstr; }
#
......@@ -289,6 +286,8 @@ sub ParRun($$$@)
my @results = ();
my $counter = 0;
my $signaled = 0;
# We need this below.
require event;
# options.
my $maxchildren = 10;
......@@ -357,10 +356,8 @@ sub ParRun($$$@)
$SIG{QUIT} = 'DEFAULT';
$SIG{HUP} = 'DEFAULT';
if ($EVENTSYS) {
# So we get the event system fork too ...
EventFork();
}
# So we get the event system fork too ...
event::EventFork();
exit(&$function($object));
}
}
......@@ -464,27 +461,4 @@ sub ParRun($$$@)
return 0;
}
#
# Check for nologins; web interface disabled means other interfaces
# should be disabled. Not using libdb:GetSiteVar cause do not want to
# drag all that stuff in. Predicate; retun 1 if no logins is set.
#
sub NoLogins()
{
my $query_result =
DBQueryWarn("select value from sitevariables ".
"where name='web/nologins'");
return 1
if (!$query_result);
return 0
if (!$query_result->numrows);
my ($value) = $query_result->fetchrow_array();
return ($value ? 1 : 0);
}
# _Always_ make sure that this 1 is at the end of the file...
1;
#!/usr/bin/perl -w
#
# EMULAB-COPYRIGHT
# Copyright (c) 2000-2010 University of Utah and the Flux Group.
# All rights reserved.
#
package libEmulab;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(SiteVarExists GetSiteVar SetSiteVar NoLogins);
use emdb;
#
# Check if a site-specific variable exists.
#
# usage: SiteVarExists($name)
# returns 1 if variable exists;
# returns 0 otherwise.
#
sub SiteVarExists($)
{
my($name) = @_;
$name = DBQuoteSpecial( $name );
my $query_result =
DBQueryWarn("select name from sitevariables where name=$name");
return 0
if (!$query_result);
return $query_result->numrows;
}
#
# Get site-specific variable.
# Get the value of the variable, or the default value if
# the value is undefined (NULL).
#
# usage: GetSiteVar($name, char \*rptr )
# Without rptr: returns value if variable is defined; dies otherwise.
# With rptr: returns value in $rptr if variable is defined; returns
# zero otherwise, or any failure.
#
sub GetSiteVar($;$)
{
my ($name, $rptr) = @_;
my $value;
$name = DBQuoteSpecial( $name );
my $query_string =
"select value,defaultvalue from sitevariables where name=$name";
my $query_result;
if (defined($rptr)) {
#
# I added the result parameter as an option to avoid changing every
# call to TBGetSiteVar(). Sorry. When called in this manner, it is
# up to the caller to decide what to do when it fails.
#
$query_result = DBQueryWarn($query_string);
return 0
if (! $query_result)
}
else {
$query_result = DBQueryFatal($query_string);
}
if ($query_result->numrows > 0) {
my ($curvalue, $defaultvalue) = $query_result->fetchrow_array();
if (defined($curvalue)) {
$value = $curvalue;
}
elsif (defined($defaultvalue)) {
$value = $defaultvalue;
}
}
if (defined($rptr)) {
if (defined($value)) {
$$rptr = $value;
return 1;
}
return 0;
}
elsif (defined($value)) {
return $value;
}
die("*** $0:\n".
" Attempted to fetch unknown site variable $name\n");
}
#
# Set a sitevar. Assumed to be a real sitevar.
#
# usage: SetSiteVar($name, $value)
#
sub SetSiteVar($$)
{
my ($name, $value) = @_;
$name = DBQuoteSpecial($name);
$value = DBQuoteSpecial($value);
my $query_result =
DBQueryWarn("update sitevariables set value=$value where name=$name");
return 0
if (!$query_result);
return 1;
}
#
# Check for nologins; web interface disabled means other interfaces
# should be disabled. Not using libdb:GetSiteVar cause do not want to
# drag all that stuff in. Predicate; retun 1 if no logins is set.
#
sub NoLogins()
{
my $query_result =
DBQueryWarn("select value from sitevariables ".
"where name='web/nologins'");
return 1
if (!$query_result);
return 0
if (!$query_result->numrows);
my ($value) = $query_result->fetchrow_array();
return ($value ? 1 : 0);
}
1;
......@@ -188,11 +188,10 @@ use vars qw(@ISA @EXPORT);
qw ( TBAdmissionControlCheck TBUpdateNodeTypeXpidPermissions );
# Must come after package declaration!
use lib '@prefix@/lib';
use English;
use libdb;
use libtestbed;
use libtblog;
use libtblog_simple;
use Experiment;
use User;
use Group;
......
This diff is collapsed.
#!/usr/bin/perl -w
#
# EMULAB-COPYRIGHT
# Copyright (c) 2005, 2006 University of Utah and the Flux Group.
# Copyright (c) 2005, 2006, 2010 University of Utah and the Flux Group.