view release on metacpan or  search on metacpan

ProcedureCall.pm  view on Meta::CPAN

			}
			else
			{
				@binder = ( $p );
			}
			# INOUT parameters
			if (ref $binder[0]){
				# default MAXLEN 100
				$binder[1] = 100 unless exists $binder[1];
				$sql->bind_param_inout(":$_", @binder);
			}
			else{
				$sql->bind_param(":$_", @binder);
			}
		}
	}
}

sub __run{
	my $w = shift;
	my $name = shift;
	my $attr = shift;
	my $dbh = shift;
	# check function/procedure attribute
	$w = 0 if $attr->{function};
	$w = undef if $attr->{procedure};
	# in void context run a procedure
	return __run_procedure($dbh, $name, $attr, @_) unless defined $w;
	# in non-void context run a function
	return __run_function($dbh, $name, $attr, @_);
}

sub run{
	my $dbh = shift;
	my $n = shift;
	my ($name, @attr) = split ':', $n;
	my @err = grep { not exists $__known_attributes{lc $_} } @attr;
	croak "tried to set unknown attributes (@err) for stored procedure '$name' " if @err;
	
	my %attr = map { (lc($_) => 1) } @attr;
	
	# any fetch implies function
	if ( grep /^fetch/,  keys %attr ) {
		$attr{'function'} = 1;
		$attr{'fetch'} = 1;
	}
	
	# cursor implies function
	$attr{'function'} = 1 if $attr{'cursor'};
	
	# table implies function
	$attr{'function'} = 1 if $attr{'table'};
	
	
	return __run(wantarray, $name, \%attr, $dbh, @_);
}


sub import {
    my $class = shift;
    my $caller = (caller)[0];
    no strict 'refs';
    foreach (@_) {
	my ($name, @attr) = split ':';
	
	my @err = grep { not exists $__known_attributes{lc $_} } @attr;
	croak "tried to set unknown attributes (@err) for stored procedure '$name' " if @err;
	
	my %attr = map { (lc($_) => 1) } @attr;
	
	
	# any fetch implies function
	if ( grep /^fetch/,  keys %attr ) {
		$attr{'function'} = 1;
		$attr{'fetch'} = 1;
	}
	
	# cursor implies function
	$attr{'function'} = 1 if $attr{'cursor'};
	
	# table implies function
	$attr{'function'} = 1 if $attr{'table'};
	
	# boolean implies function
	$attr{'function'} = 1 if $attr{'boolean'};
	
	if ($attr{'package'}){
		delete $attr{'package'};
		my $pkgname = $name;
		$pkgname =~ s/\./::/g;
		$pkgname =~ s/[^:\w]/_/g;
		*{"${pkgname}::AUTOLOAD"} = sub {__pkg_autoload($name, \%attr, @_) };
		next;
	}
	if ($attr{'packaged'}){
		delete $attr{'packaged'};
		my @p = split '\.', $name;
		die "cannot create a package for unpackaged procedure $name (name contains no dots)"
			unless @p>1;
		my $subname = pop @p;
		my $pkgname = join '::', @p;
		$pkgname =~ s/[^:\w]/_/g;
		$subname =~ s/[^:\w]/_/g;
		*{"${pkgname}::$subname"} = sub {__run(wantarray,$name,\%attr, @_) };
		next;
	}
	
	my $subname = $name;
	$subname =~ s/\W/_/g;
        *{"${caller}::$subname"} = sub { 
			__run(wantarray,$name,\%attr, @_)
		};
    }
}

sub __pkg_autoload{
	my $name = shift;
	my $attr = shift;
	my $pkgname = $name;
	$pkgname =~ s/\./::/g;
	$pkgname =~ s/[^:\w]/_/g;