2 use base qw( Exporter );
6 @EXPORT_OK $DEBUG $me $cgi $freeside_uid $conf_dir $cache_dir
7 $secrets $datasrc $db_user $db_pass $schema $dbh $driver_name
8 $AutoCommit %callback @callback $callback_hack
10 use subs qw( getsecrets );
11 use Carp qw( carp croak cluck confess );
16 @EXPORT_OK = qw( checkeuid checkruid cgi setcgi adminsuidsetup forksuidsetup
18 getotaker dbh datasrc getsecrets driver_name myconnect
24 $freeside_uid = scalar(getpwnam('freeside'));
26 $conf_dir = "%%%FREESIDE_CONF%%%";
27 $cache_dir = "%%%FREESIDE_CACHE%%%";
29 $AutoCommit = 1; #ours, not DBI
34 FS::UID - Subroutines for database login and assorted other stuff
38 use FS::UID qw(adminsuidsetup dbh datasrc checkeuid checkruid);
40 $dbh = adminsuidsetup $user;
46 $driver_name = driver_name;
50 Provides a hodgepodge of subroutines.
56 =item adminsuidsetup USER
58 Sets the user to USER (see config.html from the base documentation).
59 Cleans the environment.
60 Make sure the script is running as freeside, or setuid freeside.
61 Opens a connection to the database.
62 Runs any defined callbacks (see below).
63 Returns the DBI database handle (usually you don't need this).
68 $dbh->disconnect if $dbh;
74 warn "$me forksuidsetup starting for $user\n" if $DEBUG;
76 if ( $FS::CurrentUser::upgrade_hack ) {
77 $user = 'fs_bootstrap';
79 croak "fatal: adminsuidsetup called without arguements" unless $user;
81 $user =~ /^([\w\-\.]+)$/ or croak "fatal: illegal user $user";
91 warn "$me forksuidsetup loading user\n" if $DEBUG;
92 FS::CurrentUser->load_user($user);
98 $dbh->disconnect if $dbh;
107 $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/bin';
108 $ENV{'SHELL'} = '/bin/sh';
109 $ENV{'IFS'} = " \t\n";
112 $ENV{'BASH_ENV'} = '';
117 croak "Not running uid freeside (\$>=$>, \$<=$<)\n" unless checkeuid();
119 warn "$me forksuidsetup connecting to database\n" if $DEBUG;
122 warn "$me forksuidsetup connected to database with handle $dbh\n" if $DEBUG;
124 warn "$me forksuidsetup loading schema\n" if $DEBUG;
125 use FS::Schema qw(reload_dbdef dbdef);
126 reload_dbdef("$conf_dir/dbdef.$datasrc")
127 unless $FS::Schema::setup_hack;
129 warn "$me forksuidsetup deciding upon config system to use\n" if $DEBUG;
131 unless ( $FS::Schema::setup_hack ) {
133 #how necessary is this now that we're no longer possibly a pre-1.9 db?
134 my $sth = $dbh->prepare("SELECT COUNT(*) FROM conf") or die $dbh->errstr;
135 $sth->execute or die $sth->errstr;
136 $sth->fetchrow_arrayref->[0] or die "NO CONFIGURATION RECORDS FOUND";
145 unless ( $callback_hack ) {
146 warn "$me calling callbacks\n" if $DEBUG;
147 foreach ( keys %callback ) {
149 # breaks multi-database installs # delete $callback{$_}; #run once
152 &{$_} foreach @callback;
154 warn "$me skipping callbacks (callback_hack set)\n" if $DEBUG;
160 my $handle = DBI->connect( getsecrets(), { 'AutoCommit' => 0,
162 'ShowErrorStatement' => 1,
163 'pg_enable_utf8' => 1,
164 #'mysql_enable_utf8' => 1,
167 or die "DBI->connect error: $DBI::errstr\n";
169 $FS::Conf::conf_cache = undef;
172 use DBIx::DBSchema::_util qw(_load_driver ); #quelle hack
173 my $driver = _load_driver($handle);
174 if ( $driver =~ /^Pg/ ) {
175 no warnings 'redefine';
176 eval "sub DBIx::DBSchema::DBD::${driver}::default_db_schema {'$schema'}";
184 =item install_callback
186 A package can install a callback to be run in adminsuidsetup by passing
187 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
188 run already, the callback will also be run immediately.
190 $coderef = sub { warn "Hi, I'm returning your call!" };
191 FS::UID->install_callback($coderef);
193 install_callback FS::UID sub {
194 warn "Hi, I'm returning your call!"
199 sub install_callback {
201 my $callback = shift;
202 push @callback, $callback;
203 &{$callback} if $dbh;
208 Returns the CGI (see L<CGI>) object.
213 carp "warning: \$FS::UID::cgi is undefined" unless defined($cgi);
214 #carp "warning: \$FS::UID::cgi isa Apache" if $cgi && $cgi->isa('Apache');
220 Sets the CGI (see L<CGI>) object.
230 Returns the DBI database handle.
240 Returns the DBI data source.
250 Returns just the driver name portion of the DBI data source.
255 return $driver_name if defined $driver_name;
256 $driver_name = ( split(':', $datasrc) )[1];
260 croak "suidsetup depriciated";
265 (Deprecated) Returns the current Freeside user's username.
270 carp "FS::UID::getotaker deprecated";
271 $FS::CurrentUser::CurrentUser->username;
276 Returns true if effective UID is that of the freeside user.
281 #$> = $freeside_uid unless $>; #huh. mpm-itk hack
282 ( $> == $freeside_uid );
287 Returns true if the real UID is that of the freeside user.
292 ( $< == $freeside_uid );
297 Sets and returns the DBI datasource, username and password from
298 the `/usr/local/etc/freeside/secrets' file.
304 ($datasrc, $db_user, $db_pass, $schema) =
305 map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/secrets")
306 or die "Can't get secrets: $conf_dir/secrets: $!\n";
309 ($datasrc, $db_user, $db_pass);
316 Warning: this interface is (still) likely to change in future releases.
318 New (experimental) callback interface:
320 A package can install a callback to be run in adminsuidsetup by passing
321 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
322 run already, the callback will also be run immediately.
324 $coderef = sub { warn "Hi, I'm returning your call!" };
325 FS::UID->install_callback($coderef);
327 install_callback FS::UID sub {
328 warn "Hi, I'm returning your call!"
331 Old (deprecated) callback interface:
333 A package can install a callback to be run in adminsuidsetup by putting a
334 coderef into the hash %FS::UID::callback :
336 $coderef = sub { warn "Hi, I'm returning your call!" };
337 $FS::UID::callback{'Package::Name'} = $coderef;
341 Too many package-global variables.
345 No capabilities yet. (What does this mean again?)
347 Goes through contortions to support non-OO syntax with multiple datasrc's.
349 Callbacks are (still) inelegant.
353 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.