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
17 preuser_setup load_schema
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 warn "$me loading schema\n" if $DEBUG;
118 getsecrets() unless $datasrc;
119 use FS::Schema qw(reload_dbdef dbdef);
120 reload_dbdef("$conf_dir/dbdef.$datasrc")
121 unless $FS::Schema::setup_hack;
125 croak "Not running uid freeside (\$>=$>, \$<=$<)\n" unless checkeuid();
127 warn "$me forksuidsetup connecting to database\n" if $DEBUG;
130 warn "$me forksuidsetup connected to database with handle $dbh\n" if $DEBUG;
134 warn "$me forksuidsetup deciding upon config system to use\n" if $DEBUG;
136 unless ( $FS::Schema::setup_hack ) {
138 #how necessary is this now that we're no longer possibly a pre-1.9 db?
139 my $sth = $dbh->prepare("SELECT COUNT(*) FROM conf") or die $dbh->errstr;
140 $sth->execute or die $sth->errstr;
141 $sth->fetchrow_arrayref->[0] or die "NO CONFIGURATION RECORDS FOUND";
150 unless ( $callback_hack ) {
151 warn "$me calling callbacks\n" if $DEBUG;
152 foreach ( keys %callback ) {
154 # breaks multi-database installs # delete $callback{$_}; #run once
157 &{$_} foreach @callback;
159 warn "$me skipping callbacks (callback_hack set)\n" if $DEBUG;
165 my $handle = DBI->connect( getsecrets(), { 'AutoCommit' => 0,
167 'ShowErrorStatement' => 1,
168 'pg_enable_utf8' => 1,
169 #'mysql_enable_utf8' => 1,
172 or die "DBI->connect error: $DBI::errstr\n";
174 $FS::Conf::conf_cache = undef;
177 use DBIx::DBSchema::_util qw(_load_driver ); #quelle hack
178 my $driver = _load_driver($handle);
179 if ( $driver =~ /^Pg/ ) {
180 no warnings 'redefine';
181 eval "sub DBIx::DBSchema::DBD::${driver}::default_db_schema {'$schema'}";
189 =item install_callback
191 A package can install a callback to be run in adminsuidsetup by passing
192 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
193 run already, the callback will also be run immediately.
195 $coderef = sub { warn "Hi, I'm returning your call!" };
196 FS::UID->install_callback($coderef);
198 install_callback FS::UID sub {
199 warn "Hi, I'm returning your call!"
204 sub install_callback {
206 my $callback = shift;
207 push @callback, $callback;
208 &{$callback} if $dbh;
213 Returns the CGI (see L<CGI>) object.
218 carp "warning: \$FS::UID::cgi is undefined" unless defined($cgi);
219 #carp "warning: \$FS::UID::cgi isa Apache" if $cgi && $cgi->isa('Apache');
225 Sets the CGI (see L<CGI>) object.
235 Returns the DBI database handle.
245 Returns the DBI data source.
255 Returns just the driver name portion of the DBI data source.
260 return $driver_name if defined $driver_name;
261 $driver_name = ( split(':', $datasrc) )[1];
265 croak "suidsetup depriciated";
270 (Deprecated) Returns the current Freeside user's username.
275 carp "FS::UID::getotaker deprecated";
276 $FS::CurrentUser::CurrentUser->username;
281 Returns true if effective UID is that of the freeside user.
286 #$> = $freeside_uid unless $>; #huh. mpm-itk hack
287 ( $> == $freeside_uid );
292 Returns true if the real UID is that of the freeside user.
297 ( $< == $freeside_uid );
302 Sets and returns the DBI datasource, username and password from
303 the `/usr/local/etc/freeside/secrets' file.
309 ($datasrc, $db_user, $db_pass, $schema) =
310 map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/secrets")
311 or die "Can't get secrets: $conf_dir/secrets: $!\n";
314 ($datasrc, $db_user, $db_pass);
321 Warning: this interface is (still) likely to change in future releases.
323 New (experimental) callback interface:
325 A package can install a callback to be run in adminsuidsetup by passing
326 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
327 run already, the callback will also be run immediately.
329 $coderef = sub { warn "Hi, I'm returning your call!" };
330 FS::UID->install_callback($coderef);
332 install_callback FS::UID sub {
333 warn "Hi, I'm returning your call!"
336 Old (deprecated) callback interface:
338 A package can install a callback to be run in adminsuidsetup by putting a
339 coderef into the hash %FS::UID::callback :
341 $coderef = sub { warn "Hi, I'm returning your call!" };
342 $FS::UID::callback{'Package::Name'} = $coderef;
346 Too many package-global variables.
350 No capabilities yet. (What does this mean again?)
352 Goes through contortions to support non-OO syntax with multiple datasrc's.
354 Callbacks are (still) inelegant.
358 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.