view release on metacpan or  search on metacpan

lib/DBI/Shell.pm  view on Meta::CPAN

    return $sh;
}

# Used to install, configure, or change an option or command.
sub install_options {
	my ($sh, $options) = @_;

	my @po;
	$sh->log( "reference type: " . ref $options )
		if $sh->{debug};

	if ( ref $options eq 'ARRAY' ) {

		foreach my $opt_ref ( @$options )
		#[ 'debug|d=i'		=> ($ENV{DBISH_DEBUG} || 0) ],
		#[ 'seperator|sep=s'		=> ',' ],) 
		{
			if ( ref $opt_ref eq 'ARRAY' ) {
				$sh->install_options( $opt_ref );
			} else {
				push( @po, $opt_ref );
			}
		}
	} elsif ( ref $options eq 'HASH' ) {
		foreach (keys %{$options}) {
			push(@po, $_, $options->{$_});
		}
	} elsif ( ref $options eq 'SCALAR' ) {
		push( @po, $$options );
	} else {
		return unless $options;
		push( @po, $options );
	}

	return unless @po;

	eval{ $sh->add_option(@po) };
	# Option exists, just change it.
	if ($@ =~ /add_option/) {
		$sh->do_option( join( '=',@po ) );
	} else {
		croak "configuration: $@\n" if $@;
	}
}

sub configuration {
	my $sh = shift;

    # Source config file which may override the defaults.
    # Default is $ENV{HOME}/.dbish_config.
    # Can be overridden with $ENV{DBISH_CONFIG}.
    # Make $ENV{DBISH_CONFIG} empty to prevent sourcing config file.
    # XXX all this will change
    my $homedir = $ENV{HOME}				# unix
		|| "$ENV{HOMEDRIVE}$ENV{HOMEPATH}";	# NT
    $sh->{config_file} = $ENV{DBISH_CONFIG} || "$homedir/.dbish_config";
	my $config;
    if ($sh->{config_file} && -f $sh->{config_file}) {
		my $full = File::Spec->rel2abs( $sh->{config_file} );
		$config = require $full;
		# allow for custom configuration options.
		if (exists $config->{'options'} ) {
			$sh->install_options( $config->{'options'} );
		}
    }
	return $config;
}


sub run {
    my $sh = shift;

    my $current_line = '';

    while (1) {
	my $prefix = $sh->{command_prefix};

	$current_line = $sh->readline($sh->prompt());
	$current_line = "/quit" unless defined $current_line;

	my $copy_cline = $current_line; my $eat_line = 0;
	# move past command prefix contained within quotes
	while( $copy_cline =~ s/(['"][^'"]*(?:$prefix).*?['"])//og ) {
		$eat_line = $+[0];
	}

	# What's left to check?
	my $line;
	if ($eat_line > 0) {
	    $sh->{current_buffer} .= substr( $current_line, 0, $eat_line ) . "\n";
		$current_line = substr( $current_line, $eat_line )
			if (length($current_line) >= $eat_line );
	} else {
		$current_line = $copy_cline;
	}


	if ( 
		$current_line =~ m/
			^(.*?)
			(?<!\\)
			$prefix
			(?:(\w*)
			([^\|><]*))?
			((?:\||>>?|<<?).+)?
			$
	/x) {
	    my ($stmt, $cmd, $args_string, $output) = ($1, $2, $3, $4||''); 

		# print "$stmt -- $cmd -- $args_string -- $output\n";
	    # $sh->{current_buffer} .= "$stmt\n" if length $stmt;
		if (length $stmt) {
			$stmt =~ s/\\$prefix/$prefix/g;
			$sh->{current_buffer} .= "$stmt\n";
			if ($sh->is_spooling) { print ${$sh->{spool_fh}} ($stmt, "\n\n") }
		}

	    $cmd = 'go' if $cmd eq '';
	    my @args = split ' ', $args_string||'';