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
21 getotaker dbh datasrc getsecrets driver_name myconnect
28 $freeside_uid = scalar(getpwnam('freeside'));
30 $conf_dir = "%%%FREESIDE_CONF%%%";
31 $cache_dir = "%%%FREESIDE_CACHE%%%";
33 $AutoCommit = 1; #ours, not DBI
39 FS::UID - Subroutines for database login and assorted other stuff
43 use FS::UID qw(adminsuidsetup cgisuidsetup dbh datasrc getotaker
49 $dbh = cgisuidsetup($cgi);
55 $driver_name = driver_name;
59 Provides a hodgepodge of subroutines.
65 =item adminsuidsetup USER
67 Sets the user to USER (see config.html from the base documentation).
68 Cleans the environment.
69 Make sure the script is running as freeside, or setuid freeside.
70 Opens a connection to the database.
71 Swaps real and effective UIDs.
72 Runs any defined callbacks (see below).
73 Returns the DBI database handle (usually you don't need this).
78 $dbh->disconnect if $dbh;
85 warn "$me forksuidsetup starting for $user\n" if $DEBUG;
87 if ( $FS::CurrentUser::upgrade_hack ) {
88 $user = 'fs_bootstrap';
90 croak "fatal: adminsuidsetup called without arguements" unless $user;
92 $user =~ /^([\w\-\.]+)$/ or croak "fatal: illegal user $user";
96 $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/usr/ucb:/bin';
97 $ENV{'SHELL'} = '/bin/sh';
98 $ENV{'IFS'} = " \t\n";
101 $ENV{'BASH_ENV'} = '';
103 croak "Not running uid freeside (\$>=$>, \$<=$<)\n" unless checkeuid();
105 warn "$me forksuidsetup connecting to database\n" if $DEBUG;
106 if ( $FS::CurrentUser::upgrade_hack && $olduser ) {
107 $dbh = &myconnect($olduser);
111 warn "$me forksuidsetup connected to database with handle $dbh\n" if $DEBUG;
113 warn "$me forksuidsetup loading schema\n" if $DEBUG;
114 use FS::Schema qw(reload_dbdef dbdef);
115 reload_dbdef("$conf_dir/dbdef.$datasrc")
116 unless $FS::Schema::setup_hack;
118 warn "$me forksuidsetup deciding upon config system to use\n" if $DEBUG;
120 if ( ! $FS::Schema::setup_hack && dbdef->table('conf') ) {
122 my $sth = $dbh->prepare("SELECT COUNT(*) FROM conf") or die $dbh->errstr;
123 $sth->execute or die $sth->errstr;
124 my $confcount = $sth->fetchrow_arrayref->[0];
129 die "NO CONFIGURATION RECORDS FOUND";
133 die "NO CONFIGURATION TABLE FOUND" unless $FS::Schema::setup_hack;
136 unless ( $callback_hack ) {
137 warn "$me calling callbacks\n" if $DEBUG;
138 foreach ( keys %callback ) {
140 # breaks multi-database installs # delete $callback{$_}; #run once
143 &{$_} foreach @callback;
145 warn "$me skipping callbacks (callback_hack set)\n" if $DEBUG;
148 warn "$me forksuidsetup loading user\n" if $DEBUG;
149 FS::CurrentUser->load_user($user);
154 # start of backported functions from HEAD/4.x only used in development w/
155 # a new style AuthCookie setup
157 $dbh->disconnect if $dbh;
166 $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/bin';
167 $ENV{'SHELL'} = '/bin/sh';
168 $ENV{'IFS'} = " \t\n";
171 $ENV{'BASH_ENV'} = '';
178 croak "Not running uid freeside (\$>=$>, \$<=$<)\n" unless checkeuid();
180 warn "$me forksuidsetup connecting to database\n" if $DEBUG;
181 if ( $FS::CurrentUser::upgrade_hack && $olduser ) {
182 $dbh = &myconnect($olduser);
186 warn "$me forksuidsetup connected to database with handle $dbh\n" if $DEBUG;
188 warn "$me forksuidsetup loading schema\n" if $DEBUG;
189 use FS::Schema qw(reload_dbdef dbdef);
190 reload_dbdef("$conf_dir/dbdef.$datasrc")
191 unless $FS::Schema::setup_hack;
193 warn "$me forksuidsetup deciding upon config system to use\n" if $DEBUG;
195 if ( ! $FS::Schema::setup_hack && dbdef->table('conf') ) {
197 my $sth = $dbh->prepare("SELECT COUNT(*) FROM conf") or die $dbh->errstr;
198 $sth->execute or die $sth->errstr;
199 my $confcount = $sth->fetchrow_arrayref->[0];
204 die "NO CONFIGURATION RECORDS FOUND";
208 die "NO CONFIGURATION TABLE FOUND" unless $FS::Schema::setup_hack;
213 # end of backported functions from HEAD/4.x only used in development
217 unless ( $callback_hack ) {
218 warn "$me calling callbacks\n" if $DEBUG;
219 foreach ( keys %callback ) {
221 # breaks multi-database installs # delete $callback{$_}; #run once
224 &{$_} foreach @callback;
226 warn "$me skipping callbacks (callback_hack set)\n" if $DEBUG;
233 my $handle = FS::DBI->connect(
238 'ShowErrorStatement' => 1,
239 'pg_enable_utf8' => 1,
240 # 'mysql_enable_utf8' => 1,
242 ) or die "FS::DBI->connect error: $FS::DBI::errstr\n";
245 use DBIx::DBSchema::_util qw(_load_driver ); #quelle hack
246 my $driver = _load_driver($handle);
247 if ( $driver =~ /^Pg/ ) {
248 no warnings 'redefine';
249 eval "sub DBIx::DBSchema::DBD::${driver}::default_db_schema {'$schema'}";
257 =item install_callback
259 A package can install a callback to be run in adminsuidsetup by passing
260 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
261 run already, the callback will also be run immediately.
263 $coderef = sub { warn "Hi, I'm returning your call!" };
264 FS::UID->install_callback($coderef);
266 install_callback FS::UID sub {
267 warn "Hi, I'm returning your call!"
272 sub install_callback {
274 my $callback = shift;
275 push @callback, $callback;
276 &{$callback} if $dbh;
279 =item cgisuidsetup CGI_object
281 Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>)
282 object (CGI::Base is depriciated). Runs cgisetotaker and then adminsuidsetup.
288 if ( $cgi->isa('CGI::Base') ) {
289 carp "Use of CGI::Base is depriciated";
290 } elsif ( $cgi->isa('Apache') ) {
292 } elsif ( ! $cgi->isa('CGI') ) {
293 croak "fatal: unrecognized object $cgi";
296 adminsuidsetup($user);
301 Returns the CGI (see L<CGI>) object.
306 carp "warning: \$FS::UID::cgi isa Apache" if $cgi->isa('Apache');
312 Returns the DBI database handle.
322 Returns the DBI data source.
332 Returns just the driver name portion of the DBI data source.
337 return $driver_name if defined $driver_name;
338 $driver_name = ( split(':', $datasrc) )[1];
342 croak "suidsetup depriciated";
347 Returns the current Freeside user.
357 Sets and returns the CGI REMOTE_USER. $cgi should be defined as a CGI.pm
358 object (see L<CGI>) or an Apache object (see L<Apache>). Support for CGI::Base
359 and derived classes is depriciated.
364 if ( $cgi && $cgi->isa('CGI::Base') && defined $cgi->var('REMOTE_USER')) {
365 carp "Use of CGI::Base is depriciated";
366 $user = lc ( $cgi->var('REMOTE_USER') );
367 } elsif ( $cgi && $cgi->isa('CGI') && defined $cgi->remote_user ) {
368 $user = lc ( $cgi->remote_user );
369 } elsif ( $cgi && $cgi->isa('Apache') ) {
370 $user = lc ( $cgi->connection->user );
372 die "fatal: Can't get REMOTE_USER! for cgi $cgi - you need to setup ".
373 "Apache user authentication as documented in the installation instructions";
380 Returns true if effective UID is that of the freeside user.
385 #$> = $freeside_uid unless $>; #huh. mpm-itk hack
386 ( $> == $freeside_uid );
391 Returns true if the real UID is that of the freeside user.
396 ( $< == $freeside_uid );
399 =item getsecrets [ USER ]
401 Sets the user to USER, if supplied.
402 Sets and returns the DBI datasource, username and password for this user from
403 the `/usr/local/etc/freeside/mapsecrets' file.
408 my($setuser) = shift;
409 $user = $setuser if $setuser;
411 if ( -e "$conf_dir/mapsecrets" ) {
412 die "No user!" unless $user;
413 my($line) = grep /^\s*($user|\*)\s/,
414 map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
415 confess "User $user not found in mapsecrets!" unless $line;
416 $line =~ /^\s*($user|\*)\s+(.*)$/;
418 die "Illegal mapsecrets line for user?!" unless $secrets;
420 # no mapsecrets file at all, so do the default thing
421 $secrets = 'secrets';
424 ($datasrc, $db_user, $db_pass, $schema) =
425 map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
426 or die "Can't get secrets: $conf_dir/$secrets: $!\n";
429 ($datasrc, $db_user, $db_pass);
434 Returns true whenever we should use 1.7 configuration compatibility.
446 Warning: this interface is (still) likely to change in future releases.
448 New (experimental) callback interface:
450 A package can install a callback to be run in adminsuidsetup by passing
451 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
452 run already, the callback will also be run immediately.
454 $coderef = sub { warn "Hi, I'm returning your call!" };
455 FS::UID->install_callback($coderef);
457 install_callback FS::UID sub {
458 warn "Hi, I'm returning your call!"
461 Old (deprecated) callback interface:
463 A package can install a callback to be run in adminsuidsetup by putting a
464 coderef into the hash %FS::UID::callback :
466 $coderef = sub { warn "Hi, I'm returning your call!" };
467 $FS::UID::callback{'Package::Name'} = $coderef;
471 Too many package-global variables.
475 No capabilities yet. When mod_perl and Authen::DBI are implemented,
476 cgisuidsetup will go away as well.
478 Goes through contortions to support non-OO syntax with multiple datasrc's.
480 Callbacks are (still) inelegant.
484 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.