goto-common 3.1-1.1 / usr / share / perl5 / GOto / Common.pm

package GOto::Common;
# $Id$

use strict;
use Net::LDAP;
use Net::LDAP::Constant qw(LDAP_NO_SUCH_OBJECT LDAP_REFERRAL);
use URI;

BEGIN
{
  use Exporter ();
  use vars qw(%EXPORT_TAGS @ISA $VERSION);
  $VERSION = '20080116';
  @ISA = qw(Exporter);

  %EXPORT_TAGS = (
    'ldap' => [qw(
      &goto_ldap_parse_config
      &goto_ldap_parse_config_ex
      &goto_ldap_fsearch
      &goto_ldap_rsearch
      &goto_ldap_is_single_result
      &goto_ldap_split_dn
    )],
    'file' => [qw(
      &goto_file_write
      &goto_file_chown
    )],
    'array' => [qw(
      &goto_array_find_and_remove
    )],
    'string' => [qw(
      &goto_gen_random_str
    )]
  );

  Exporter::export_ok_tags(keys %EXPORT_TAGS);
}

#------------------------------------------------------------------------------

sub goto_ldap_parse_config
{
  my ($ldap_config) = @_;

  $ldap_config = $ENV{ 'LDAPCONF' }
    if( !defined $ldap_config && exists $ENV{ 'LDAPCONF' } );
  $ldap_config = "/etc/ldap/ldap.conf" 
    if( !defined $ldap_config );

  # Read LDAP
  return if( ! open (LDAPCONF,"${ldap_config}") );

  my @content=<LDAPCONF>;
  close(LDAPCONF);

  my ($ldap_base, @ldap_uris);
  # Scan LDAP config
  foreach my $line (@content) {
    $line =~ /^\s*(#|$)/ && next;
    chomp($line);

    if ($line =~ /^BASE\s+(.*)$/i) {
      $ldap_base= $1;
      next;
    }
    if ($line =~ /^URI\s+(.*)\s*$/i) {
      my (@ldap_servers) = split( ' ', $1 );
      foreach my $server (@ldap_servers) {
        if ( $server =~ /^((ldap[si]?:\/\/)([^\/:\s]+)?(:([0-9]+))?\/?)$/ ) {
          my $ldap_server = $3 ? $1 : $2.'localhost';
          $ldap_server =~ s/\/\/127\.0\.0\.1/\/\/localhost/;
          push @ldap_uris, $ldap_server 
            if ( $1 && ! grep { $_ =~ /^$ldap_server$/ } @ldap_uris );
        }
      }
      next;
    }
  }

  return( $ldap_base, \@ldap_uris );
}

sub goto_ldap_parse_config_ex
{
  my %result = ();

  my $ldap_info = '/etc/ldap/ldap-shell.conf';
  if ( -r '/etc/ldap/ldap-offline.conf' ) {
  	$ldap_info = '/etc/ldap/ldap-offline.conf';
  }

  if (!open( LDAPINFO, "<${ldap_info}" ))
  {
     warn "Couldn't open ldap info ($ldap_info): $!\n";
     return undef;
  }
  while( <LDAPINFO> ) {
    if( $_ =~ m/^([a-zA-Z_0-9]+)="(.*)"$/ ) {
      if ($1 eq "LDAP_URIS") {
        my @uris = split(/ /,$2);
        $result{$1} = \@uris;
      }
      else {
        $result{$1} = $2;
      }
    }
  }
  close( LDAPINFO );
  if (not exists($result{"LDAP_URIS"}))
  {
    warn "LDAP_URIS missing in file $ldap_info\n";
  }
  return \%result;
}

# Split the dn (works with escaped commas)
sub goto_ldap_split_dn {
  my ($dn) = @_;

  # Split at comma
  my @comma_rdns = split( ',', $dn );
  my @result_rdns = ();
  my $line = '';

  foreach my $rdn (@comma_rdns) {
    # Append comma and rdn to line
    if( '' eq $line ) { $line = $rdn; }
    else { $line .= ',' . $rdn; }

    # Count the backslashes at the end. If we have even length
    # of $bs add to result array and set empty line
    my($bs) = $rdn =~ m/([\\]+)$/;
    $bs = "" if( ! defined $bs );
    if( 0 == (length($bs) % 2) ) {
      push( @result_rdns, $line );
      $line = "";
    }
  }

  return @result_rdns;
}

#------------------------------------------------------------------------------

sub goto_file_write {

	my @opts = @_;
	my $len = scalar @_;
	($len < 2) && return;

	my $filename = shift;
	my $data = shift;

	open (SCRIPT,">${filename}") || warn "Can't create ${filename}. $!\n";
	print SCRIPT $data;
	close(SCRIPT);

  ($opts[2] ne "") && chmod oct($opts[2]),${filename};
	($opts[3] ne "") && goto_file_chown(${filename}, $opts[3]);
}

#------------------------------------------------------------------------------

sub goto_file_chown
{
  my @owner = split('.',$_[1]);
  my $filename = $_[0];
  my ($uid,$gid);
  $uid = getpwnam($owner[0]);
  $gid = getgrnam($owner[1]);
  
  chown $uid, $gid, $filename;
}

#
# Common checks for forward and reverse searches
#
sub goto_ldap_search_checks {
  my( $base, $sbase ) = (@_)[1,2];

  if( scalar @_ < 3 ) {
    warn( "goto_ldap_search needs at least 3 parameters" );
    return;
  };

  if( defined $sbase && (length($sbase) > 0) ) {
    # Check, if $sbase is a base of $base
    if( $sbase ne substr($base,-1 * length($sbase)) ) {
      warn( "goto_ldap_search: (1) '$sbase' isn't the base of '$base'" );
      return;
    }

    $base = substr( $base, 0, length( $base ) - length( $sbase ) );

    # Check, if $base ends with ',' after $sbase strip
    if( ',' ne substr( $base, -1 ) ) {
      warn( "goto_ldap_search: (2) '$sbase' isn't the base of '$base'" );
      return;
    }
    $base  = substr( $base, 0, length($base) - 1 );
    $sbase = ',' . $sbase;
  }
  else { $sbase = ''; }

  return( $base, $sbase );
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#
# $ldap    = Net::LDAP handle
# $base    = Search base ( i.e.: ou=test,ou=me,ou=very,ou=well )
# $sbase   = Stop base ( i.e.: ou=very,ou=well )
# $filter  = LDAP filter
# $scope   = LDAP scope
# $subbase = On every $base look into $subbase,$base ( i.e.: ou=do )
# $attrs   = Result attributes
#
# Example searches in:
#   ou=do,ou=test,ou=me,ou=very,ou=well
#   ou=do,ou=me,ou=very,ou=well
#   ou=do,ou=very,ou=well
#
# Returns (Net::LDAP::Search, $search_base) on LDAP failure
# Returns (Net::LDAP::Search, $search_base) on success
# Returns undef on non-LDAP failures
#
sub goto_ldap_rsearch {
  use Switch;

  my ($ldap,$base,$sbase,$filter,$scope,$subbase,$attrs) = @_;

  ( $base, $sbase ) = goto_ldap_search_checks( @_ );
  return if( ! defined $base );

  my (@rdns,$search_base,$mesg);

  @rdns = goto_ldap_split_dn( $base );
  return if( 0 == scalar @rdns );

  while( 1 ) {

    # Walk the DN tree
    switch( scalar @rdns ) {
    case 0 {
      # We also want to search the stop base, if it was defined
      return if( ! defined $sbase );
      if( length( $sbase ) > 0 )
        { $search_base = substr( $sbase, 1 ); }
      else { $search_base = ''; }
      undef( $sbase );
      }
    else {
      $search_base = join( ',', @rdns ); 
      shift(@rdns);
      $search_base .= $sbase;
      }
    }

    # Initialize hash with filter
    my %opts = ( 'filter' => $filter );

    # Set searchbase
    if( defined $subbase && $subbase ) 
      { $opts{ 'base' } = "${subbase},${search_base}" }
    else { $opts{ 'base' } = "${search_base}" }

    # Set scope
    $opts{ 'scope' } = "$scope" if( defined $scope && $scope );
    $opts{ 'attrs' } = @$attrs if( defined $attrs );

    # LDAP search

    # The referral chasing is much simpler then the OpenLDAP one.
    # It's just single level support, therefore it can't really
    # chase a trail of referrals, but will check a list of them.

    my @referrals;
    my $chase_referrals = 0;
RETRY_SEARCH:
    $mesg = $ldap->search( %opts );

    if( LDAP_REFERRAL == $mesg->code ) { # Follow the referral
      if( ! $chase_referrals ) {
        my @result_referrals = $mesg->referrals();
        foreach my $referral (@result_referrals) {
          my $uri = new URI( $referral );
          next if( $uri->dn ne $opts{ 'base' } ); # But just if we have the same base
          push( @referrals, $uri );
        }
        $chase_referrals = 1;
      }

NEXT_REFERRAL:
      next if( ! length @referrals );
      my $uri = new URI( $referrals[ 0 ] );
      $ldap = new Net::LDAP( $uri->host );
      @referrals = splice( @referrals, 1 );
      goto NEXT_REFERRAL if( ! defined $ldap );
      $mesg = $ldap->bind();
      goto NEXT_REFERRAL if( 0 != $mesg->code );
      goto RETRY_SEARCH;
    }
    if( LDAP_NO_SUCH_OBJECT == $mesg->code ) { # Ignore missing objects (32)
      goto NEXT_REFERRAL if( scalar @referrals );
      next;
    }

    return $mesg if( $mesg->code ); # Return undef on other failures

    last if( $mesg->count() > 0 );
  }

  return( $mesg, ${search_base} );
}

#------------------------------------------------------------------------------
# See goto_ldap_rsearch
#
# sbase = start base
#
# Example searches in:
#   ou=do,ou=very,ou=well
#   ou=do,ou=me,ou=very,ou=well
#   ou=do,ou=test,ou=me,ou=very,ou=well
# 
sub goto_ldap_fsearch {
  use Switch;

  my ($ldap,$base,$sbase,$filter,$scope,$subbase,$attrs) = @_;

  ( $base, $sbase ) = goto_ldap_search_checks( @_ );
  return if( ! defined $base );

  my (@rdns,$search_base,$mesg,$rdn_count);

  @rdns = reverse goto_ldap_split_dn( $base );
  $rdn_count = scalar @rdns;
  return if( 0 == $rdn_count );

  while( 1 ) {

    # Walk the DN tree
    if( ! defined $search_base ) {
      # We need to strip the leading ",", which is needed for research
      if( length( $sbase ) > 0 )
        { $search_base = substr( $sbase, 1 ); }
      else { $search_base = ''; }
    }
    elsif( 0 == scalar @rdns ) {
      return undef;
    }
    else {
      $search_base = $rdns[ 0 ] . ',' . $search_base;
      shift(@rdns);
    }

    # Initialize hash with filter
    my %opts = ( 'filter' => $filter );

    # Set searchbase
    if( defined $subbase && $subbase ) 
      { $opts{ 'base' } = "${subbase},${search_base}"; }
    else { $opts{ 'base' } = "${search_base}"; }

    # Set scope
    $opts{ 'scope' } = "$scope" if( defined $scope && $scope );
    $opts{ 'attrs' } = @$attrs if( defined $attrs );

    # LDAP search
    $mesg = $ldap->search( %opts );

    next if( $mesg->code == 32 ); # Ignore missing objects (32)
    return $mesg if( $mesg->code ); # Return undef on other failures

    last if( $mesg->count() > 0 );
  }

  return( $mesg, ${search_base} );
}


#------------------------------------------------------------------------------
#
# $search_result = Net::LDAP::Serach
# $get_entry     = boolean
#
# if $get_entry == true,  return $entry 
#               == false, return 1
#
# returns 0 on failure
#
sub goto_ldap_is_single_result {
  my ($search_result,$get_entry) = @_;
  my $result = 0;
  if( (defined $search_result)
      && (0 == $search_result->code) 
      && (1 == $search_result->count()) ) 
  {
    if( defined $get_entry && $get_entry )
      { $result = ($search_result->entries())[ 0 ]; }
    else { $result = 1; }
  }
  return $result;
}


#------------------------------------------------------------------------------

sub goto_array_find_and_remove {
  my ($haystack,$needle) = @_;
  my $index = 0;

  foreach my $item (@$haystack) {
    if ($item eq $needle) {
      splice( @$haystack, $index, 1 );
      return 1;
    }
    $index++;
  }
  return 0;
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#
# Generate a random string based on a symbolset
#
# @param int $strlen: length of result string
# @param array ref: symbol set (optional)
# @return string or undef
#
sub goto_gen_random_str {
  my ($strlen, $symbolset) = @_;
  return if( (! defined $strlen) || (0 > $strlen) );
  return '' if( 0 == $strlen );
  if( (! defined $symbolset)
    || ('ARRAY' ne ref( $symbolset ))
    || (0 >= scalar( @$symbolset )) )
  {
    my @stdset = (0..9, 'a'..'z', 'A'..'Z');
    $symbolset = \@stdset;
  }

  my $randstr = join '',
    map @$symbolset[rand @$symbolset], 0..($strlen-1);
  return $randstr;
}

END {}

1;

__END__

# vim:ts=2:sw=2:expandtab:shiftwidth=2:syntax:paste