view release on metacpan or  search on metacpan

lib/CGI/Bus.pm  view on Meta::CPAN

	push @{$s->{-cache}->{-unames}}, $v
		if !grep /^\Q$v\E$/, @{$s->{-cache}->{-unames}};
    }
 }
 $_[0]->{-cache}->{-unames}
}


sub usdomain {# User names Server Domain
 if (!$_[0]->{-cache}->{-usdomain} ||$_[1]) {
    $_[0]->{-cache}->{-usdomain} =$_[1] 
     || (ref($_[0]->{-usdomain}) eq 'CODE' 
        ? &{$_[0]->{-usdomain}}(@_)
        : $_[0]->uauth->usdomain(@_[1..$#_]));
 }
 $_[0]->{-cache}->{-usdomain}
}


sub userver { # User names Server
 if (!$_[0]->{-cache}->{-userver} ||$_[1]) {
    $_[0]->{-cache}->{-userver} =$_[1]
     ||(ref($_[0]->{-userver}) eq 'CODE' 
       ? &{$_[0]->{-userver}}(@_)
       : $_[0]->uauth->userver(@_[1..$#_]));
 }
 $_[0]->{-cache}->{-userver}
}


sub ugroups { # User groups [user name]
 if (!defined($_[0]->{-cache}->{-ugroups}) 
 || ($_[1]	&& (lc($_[0]->useron	||'') ne lc($_[1]))
		&& (lc($_[0]->user	||'') ne lc($_[1])))) {
	my $s =$_[0];
	my $r =[];
	return($r) if !defined($s->user) && !$_[1];
	$r = ref($s->{-ugroups}) eq 'CODE' 
		? &{$s->{-ugroups}}(@_)
		: $_[0]->uauth->ugroups(@_[1..$#_]);
	if ($_[0]->{-ugrpcnv}) {
		my $ga =[];
		local $_;
		foreach $_ (@$r) {
			$_ =&{$_[0]->{-ugrpcnv}}(@_);
			push(@$ga, $_) if defined($_) && $_ ne '';
		}
		$r =$ga;
	}
	if ($_[0]->{-ugrpadd}) {
		local $_ =$r;
		my $ugadd=ref($s->{-ugrpadd}) eq 'CODE' ? &{$s->{-ugrpadd}}(@_) : $s->{-ugrpadd};
		foreach my $e (	  ref($ugadd) eq 'ARRAY'
				? @{$ugadd}
				: ref($ugadd) eq 'HASH'
				? keys(%$ugadd)
				: $ugadd){
			push @$r, $e if !grep /^\Q$e\E$/i, @$r
		}
	}
	{ use locale;
	  $r =[sort {lc($a) cmp lc($b)} @$r];
	}
	$s->{-cache}->{-ugroups} =$r 
		if !$_[1]
		|| (lc($_[0]->useron)	eq lc($_[1]))
		|| (lc($_[0]->user)	eq lc($_[1]));
	return($r)
 }
 $_[0]->{-cache}->{-ugroups}
}


sub ugnames { # User & Group Names
 if (!defined($_[0]->{-cache}->{-ugnames})) {
    my $s =$_[0];
    return('') if !defined($s->user);
    $s->{-cache}->{-ugnames} =[];
    push @{$s->{-cache}->{-ugnames}}, @{$s->unames};
    push @{$s->{-cache}->{-ugnames}}, @{$s->ugroups};
 }
 $_[0]->{-cache}->{-ugnames}
}


sub uglist {  # User & Group List
 my $s =shift;
 my $o =defined($_[0]) && substr($_[0],0,1) eq '-' ? shift : '-ug';
 my $r =
     ref($s->{-uglist}) eq 'CODE' ? &{$s->{-uglist}}($s,$o,@_)
                                  : $s->uauth->uglist($o,@_);
 if ($s->{-ugrpadd}) {
	local $_ =$r;
	my $ugadd=ref($s->{-ugrpadd}) eq 'CODE' ? &{$s->{-ugrpadd}}(@_) : $s->{-ugrpadd};
	if ((ref($r) eq 'HASH')
	&&  (ref($ugadd) eq 'HASH')) {
		foreach my $e (keys(%$ugadd)) {
			$r->{$e} =$ugadd->{$e} if !$r->{$e}
		}
	}
	else {
		foreach my $e (	  ref($ugadd) eq 'ARRAY'
				? @{$ugadd}
				: ref($ugadd) eq 'HASH'
				? keys(%$ugadd)
				: $ugadd){
			if (ref($r) eq 'HASH') {
				$r->{$e} =$e if !$r->{$e}
			}
			else {
				push @$r, $e if !grep /^\Q$e\E$/i, @$r
			}
		}
	}
 }
 $r =do{use locale; [sort {lc($a) cmp lc($b)} @$r]} if ref($r) eq 'ARRAY';

 if ($s->{-ugrpcnv}) {
    local $_;
    if (ref($r) eq 'ARRAY') {
       my @g;
       foreach $_ (@$r) {
          $_ =&{$s->{-ugrpcnv}}($s,$o);
          push(@g, $_) if defined($_) && $_ ne '';
       }
       $r =[sort {lc($a) cmp lc($b)} @g];
    }
    else {
       my $w =$_[1]; # width of label
       foreach my $k (keys %$r) {
         $_ =$k;
         $_ =&{$s->{-ugrpcnv}}($s,$o);
         if (defined($_) && $_ ne '') {
            $r->{$_} =$r->{$k};
            $r->{$_} =substr($r->{$_},0,$w) if $w;
         }
         elsif (!defined($_) || $_ eq '' || $_ ne $k) {
            delete $r->{$k}
         }
       }
    }
 }
 $r
}


sub unamesun {# User Names Unique list
 my $s =shift;
 my $r =[];
 foreach my $n (ref($_[0]) ? @{$_[0]} : @_) {
   next if grep {lc($n) eq lc($_) 
              || lc($s->usercn($n)) eq lc($s->usercn($_))} @$r;
   push @$r, $n;
 }
 $r
}


sub userauth {# User Authenticate
 my $s =shift;
 $s->{-w32IISdpsn} =($ENV{SERVER_SOFTWARE}||'') !~/IIS/ 
	? 0
	: ($s->{-login}||'') =~/\/$/i
	? 2
	: 0
	if !defined($s->{-w32IISdpsn});
 ref($s->{-userauth}) eq 'CODE'    ? &{$s->{-userauth}}($s,@_)
 : ref($s->{-userauth}) eq 'ARRAY' ? $s->uauth->auth($s->{-userauth},@_)
 : $s->{-userauth}                 ? $s->uauth->auth([$s->{-userauth}],@_)
 : $s->uauth->auth(@_);
 $s->{-cache}->{-userauth} =$s->user
}



sub userauthopt { # User Authenticate optional