5 @ISA @EXPORT_OK $DEBUG $me $cgi $freeside_uid $user $conf_dir $cache_dir
6 $secrets $datasrc $db_user $db_pass $schema $dbh $driver_name
7 $AutoCommit %callback @callback $callback_hack $use_confcompat
10 getsecrets cgisetotaker
13 use Carp qw(carp croak cluck confess);
19 @EXPORT_OK = qw(checkeuid checkruid cgisuidsetup adminsuidsetup forksuidsetup
20 getotaker dbh datasrc getsecrets driver_name myconnect
26 $freeside_uid = scalar(getpwnam('freeside'));
28 $conf_dir = "%%%FREESIDE_CONF%%%";
29 $cache_dir = "%%%FREESIDE_CACHE%%%";
31 $AutoCommit = 1; #ours, not DBI
37 FS::UID - Subroutines for database login and assorted other stuff
41 use FS::UID qw(adminsuidsetup cgisuidsetup dbh datasrc getotaker
47 $dbh = cgisuidsetup($cgi);
53 $driver_name = driver_name;
57 Provides a hodgepodge of subroutines.
63 =item adminsuidsetup USER
65 Sets the user to USER (see config.html from the base documentation).
66 Cleans the environment.
67 Make sure the script is running as freeside, or setuid freeside.
68 Opens a connection to the database.
69 Swaps real and effective UIDs.
70 Runs any defined callbacks (see below).
71 Returns the DBI database handle (usually you don't need this).
76 $dbh->disconnect if $dbh;
83 warn "$me forksuidsetup starting for $user\n" if $DEBUG;
85 if ( $FS::CurrentUser::upgrade_hack ) {
86 $user = 'fs_bootstrap';
88 croak "fatal: adminsuidsetup called without arguements" unless $user;
90 $user =~ /^([\w\-\.]+)$/ or croak "fatal: illegal user $user";
94 $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/usr/ucb:/bin';
95 $ENV{'SHELL'} = '/bin/sh';
96 $ENV{'IFS'} = " \t\n";
99 $ENV{'BASH_ENV'} = '';
101 croak "Not running uid freeside (\$>=$>, \$<=$<)\n" unless checkeuid();
103 warn "$me forksuidsetup connecting to database\n" if $DEBUG;
104 if ( $FS::CurrentUser::upgrade_hack && $olduser ) {
105 $dbh = &myconnect($olduser);
109 warn "$me forksuidsetup connected to database with handle $dbh\n" if $DEBUG;
111 warn "$me forksuidsetup loading schema\n" if $DEBUG;
112 use FS::Schema qw(reload_dbdef dbdef);
113 reload_dbdef("$conf_dir/dbdef.$datasrc")
114 unless $FS::Schema::setup_hack;
116 warn "$me forksuidsetup deciding upon config system to use\n" if $DEBUG;
118 if ( ! $FS::Schema::setup_hack && dbdef->table('conf') ) {
120 my $sth = $dbh->prepare("SELECT COUNT(*) FROM conf") or die $dbh->errstr;
121 $sth->execute or die $sth->errstr;
122 my $confcount = $sth->fetchrow_arrayref->[0];
127 warn "NO CONFIGURATION RECORDS FOUND";
131 warn "NO CONFIGURATION TABLE FOUND" unless $FS::Schema::setup_hack;
134 unless ( $callback_hack ) {
135 warn "$me calling callbacks\n" if $DEBUG;
136 foreach ( keys %callback ) {
138 # breaks multi-database installs # delete $callback{$_}; #run once
141 &{$_} foreach @callback;
143 warn "$me skipping callbacks (callback_hack set)\n" if $DEBUG;
146 warn "$me forksuidsetup loading user\n" if $DEBUG;
147 FS::CurrentUser->load_user($user);
153 my $handle = DBI->connect( getsecrets(@_), { 'AutoCommit' => 0,
155 'ShowErrorStatement' => 1,
158 or die "DBI->connect error: $DBI::errstr\n";
161 use DBIx::DBSchema::_util qw(_load_driver ); #quelle hack
162 my $driver = _load_driver($handle);
163 if ( $driver =~ /^Pg/ ) {
164 no warnings 'redefine';
165 eval "sub DBIx::DBSchema::DBD::${driver}::default_db_schema {'$schema'}";
173 =item install_callback
175 A package can install a callback to be run in adminsuidsetup by passing
176 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
177 run already, the callback will also be run immediately.
179 $coderef = sub { warn "Hi, I'm returning your call!" };
180 FS::UID->install_callback($coderef);
182 install_callback FS::UID sub {
183 warn "Hi, I'm returning your call!"
188 sub install_callback {
190 my $callback = shift;
191 push @callback, $callback;
192 &{$callback} if $dbh;
195 =item cgisuidsetup CGI_object
197 Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>)
198 object (CGI::Base is depriciated). Runs cgisetotaker and then adminsuidsetup.
204 if ( $cgi->isa('CGI::Base') ) {
205 carp "Use of CGI::Base is depriciated";
206 } elsif ( $cgi->isa('Apache') ) {
208 } elsif ( ! $cgi->isa('CGI') ) {
209 croak "fatal: unrecognized object $cgi";
212 adminsuidsetup($user);
217 Returns the CGI (see L<CGI>) object.
222 carp "warning: \$FS::UID::cgi isa Apache" if $cgi->isa('Apache');
228 Returns the DBI database handle.
238 Returns the DBI data source.
248 Returns just the driver name portion of the DBI data source.
253 return $driver_name if defined $driver_name;
254 $driver_name = ( split(':', $datasrc) )[1];
258 croak "suidsetup depriciated";
263 Returns the current Freeside user.
273 Sets and returns the CGI REMOTE_USER. $cgi should be defined as a CGI.pm
274 object (see L<CGI>) or an Apache object (see L<Apache>). Support for CGI::Base
275 and derived classes is depriciated.
280 if ( $cgi && $cgi->isa('CGI::Base') && defined $cgi->var('REMOTE_USER')) {
281 carp "Use of CGI::Base is depriciated";
282 $user = lc ( $cgi->var('REMOTE_USER') );
283 } elsif ( $cgi && $cgi->isa('CGI') && defined $cgi->remote_user ) {
284 $user = lc ( $cgi->remote_user );
285 } elsif ( $cgi && $cgi->isa('Apache') ) {
286 $user = lc ( $cgi->connection->user );
288 die "fatal: Can't get REMOTE_USER! for cgi $cgi - you need to setup ".
289 "Apache user authentication as documented in httemplate/docs/install.html";
296 Returns true if effective UID is that of the freeside user.
301 #$> = $freeside_uid unless $>; #huh. mpm-itk hack
302 ( $> == $freeside_uid );
307 Returns true if the real UID is that of the freeside user.
312 ( $< == $freeside_uid );
315 =item getsecrets [ USER ]
317 Sets the user to USER, if supplied.
318 Sets and returns the DBI datasource, username and password for this user from
319 the `/usr/local/etc/freeside/mapsecrets' file.
324 my($setuser) = shift;
325 $user = $setuser if $setuser;
327 if ( -e "$conf_dir/mapsecrets" ) {
328 die "No user!" unless $user;
329 my($line) = grep /^\s*($user|\*)\s/,
330 map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
331 confess "User $user not found in mapsecrets!" unless $line;
332 $line =~ /^\s*($user|\*)\s+(.*)$/;
334 die "Illegal mapsecrets line for user?!" unless $secrets;
336 # no mapsecrets file at all, so do the default thing
337 $secrets = 'secrets';
340 ($datasrc, $db_user, $db_pass, $schema) =
341 map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
342 or die "Can't get secrets: $conf_dir/$secrets: $!\n";
345 ($datasrc, $db_user, $db_pass);
350 Returns true whenever we should use 1.7 configuration compatibility.
362 Warning: this interface is (still) likely to change in future releases.
364 New (experimental) callback interface:
366 A package can install a callback to be run in adminsuidsetup by passing
367 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
368 run already, the callback will also be run immediately.
370 $coderef = sub { warn "Hi, I'm returning your call!" };
371 FS::UID->install_callback($coderef);
373 install_callback FS::UID sub {
374 warn "Hi, I'm returning your call!"
377 Old (deprecated) callback interface:
379 A package can install a callback to be run in adminsuidsetup by putting a
380 coderef into the hash %FS::UID::callback :
382 $coderef = sub { warn "Hi, I'm returning your call!" };
383 $FS::UID::callback{'Package::Name'} = $coderef;
387 Too many package-global variables.
391 No capabilities yet. When mod_perl and Authen::DBI are implemented,
392 cgisuidsetup will go away as well.
394 Goes through contortions to support non-OO syntax with multiple datasrc's.
396 Callbacks are (still) inelegant.
400 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.