^sub \w+\( results from the CPAN

use strict;

use Asterisk::config;
use Dahdi::Config::Gen qw(is_true);

sub new($$$) {
	my $pack = shift || die;
	my $gconfig = shift || die;
	my $genopts = shift || die;
	my $users_file = $ENV{USERS_CONF_FILE} || "/etc/asterisk/users.conf";
	my $ext_file = $ENV{EXTENSIONS_FILE} || "/etc/asterisk/extensions.conf";

	bless $self, $pack;
	return $self;
}

# A digital trunk for a single span
sub gen_digital_trunk($$) {
	my $self = shift || die;
	my $span = shift || die;
	my $gconfig = $self->{GCONFIG};
	my $num = $span->num() || die;
	my $bchan_range = Dahdi::Config::Gen::bchan_range($span);

		]
	);
}

# A user for a single FXS port
sub gen_channel($$) {
	my $self = shift || die;
	my $chan = shift || die;
	my $gconfig = $self->{GCONFIG};
	my $type = $chan->type;
	my $num = $chan->num;

# Add instructions to remove existing relevant sections.
# Note that this function only adds the instructions to the commit_list.
# Requests will only actually be performed on on the save_file()-s in
# the end. Thus even after this function, the sections we "remove" still
# exist in fetch requests.
sub remove_old_sections($) {
	my $self = shift || die;
	my @user_del_sect = grep /^((chan|span_dahdi_)|trunk_analog$)/, 
		@{$self->{USERS}->fetch_sections_list()};
	foreach (@user_del_sect) {
		$self->{USERS}->assign_delsection(section=>$_);

	foreach (@ext_del_sect) {
		$self->{EXT}->assign_delsection(section=>$_);
	}
}

sub generate($) {
	my $self = shift || die;
	my @spans = @_;
	my $gconfig = $self->{GCONFIG};
	my $genopts = $self->{GENOPTS};
	$self->{EXTEN} = $self->{GCONFIG}->{'base_exten'};

view all matches for this distribution

Astro-Montenbruck

1 match

lib/Astro/Montenbruck/MathUtils.pm view on Meta::CPAN

    ],
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our $VERSION = 0.02;

sub frac($x) { ( modf($x) )[0] }

sub frac360($x) { frac($x) * 360 }

sub dms ( $x, $places = 3 ) {
    return $x if $places == 1;

    my ( $f, $i ) = modf($x);

lib/Astro/Montenbruck/MathUtils.pm view on Meta::CPAN

    ( $i, dms( $f * 60, $places - 1 ) );
}

sub hms { dms @_ }

sub zdms($x) {
    my ( $d, $m, $s ) = dms($x);
    my $z = int( $d / 30 );
    $d %= 30;

    $z, $d, $m, $s;
}

sub ddd(@args) {
    my $b = any { $_ < 0 } @args;
    my $sgn = $b ? -1 : 1;
    my ( $d, $m, $s ) = map { abs( $args[$_] || 0 ) } ( 0 .. 2 );
    return $sgn * ( $d + ( $m + $s / 60.0 ) / 60.0 );
}

lib/Astro/Montenbruck/MathUtils.pm view on Meta::CPAN

    $x < 0 ? $x + $limit : $x;
}

#sub reduce_deg($x) { to_range( $x, 360 ) }

sub reduce_deg($x) {
    my $res = Math::Trig::deg2deg($x);
    $res < 0 ? $res + 360 : $res;
}

#sub reduce_rad($x) { to_range( $x, pi2 ) }

sub reduce_rad($x) {
    my $res = Math::Trig::rad2rad($x);
    $res < 0 ? $res + pi2 : $res;
}

sub sine($x) { sin( pi2 * frac($x) ) }

sub opposite_deg($x) { reduce_deg( $x + 180 ) }

sub opposite_rad($x) { reduce_rad( $x + pi ) }

sub angle_c ( $a, $b ) {
    my $x = abs( $a - $b );
    $x > 180 ? 360 - $x : $x;
}

lib/Astro/Montenbruck/MathUtils.pm view on Meta::CPAN

    my ( $x1, $y1, $x2, $y2 ) = map { deg2rad $_ } @_;
    rad2deg(
        acos( sin($y1) * sin($y2) + cos($y1) * cos($y2) * cos( $x1 - $x2 ) ) );
}

sub diff_angle($a, $b, $mode = 'degrees') {
    my $m = lc $mode;
    my $whole = $m eq 'degrees' ? 360
                                : $m eq 'radians' ? pi2
                                                  : undef;
    die "Expected 'degrees' or 'radians' mode" unless $whole;

lib/Astro/Montenbruck/MathUtils.pm view on Meta::CPAN

    return $x - $whole if $x > $half;
    return $x;
}


sub cart( $r, $theta, $phi ) {
    my $rcst = $r * cos($theta);
    $rcst * cos($phi), $rcst * sin($phi), $r * sin($theta);
}

# in previous versions was named 'polar'

view all matches for this distribution

Astro

3 results

 Reference : Blaauw et al., 1960, MNRAS, 121, 123.

=cut

# Within 1e-7 arcsec of SLALIB slaEg50
sub fk4galr(@) {
  # First check that we have 3 arguments
  if (scalar @_ < 3) {
    croak 'Not enough arguments for Astro::Coord::fk4galr at ';
  } elsif (scalar @_ > 3) {
    croak 'Too many arguments for Astro::Coord::fk4galr at ';

 Reference : Blaauw et al., 1960, MNRAS, 121, 123.

=cut

# Within 1e-7 arcsec of SLALIB slaGe50
sub galfk4(@) {
  my (@r, $rect);

  if (@_==3) { # Rectangular coordinates passed
    @r = @_;
    $rect = 1;

  } else {
    return r2pol(@fk4);
  }
}

sub galfk4r(@) {galfk4(@_)};

#=item B<fk4fk5>
#
# ($JRA, $JDec) = fk4fk5($BRA, $BDec);
#

   @J2000         J2000 position (as a 3-vector)

=cut

# Untested
sub J2000todate(@) {

  my ($rect);
  my (@J2000, @date); #  Position  vectors

  my $mjd = pop @_;


  NOTE: returns undef if %limits hash is missing any of the required keys

=cut

sub haset_ewxy($$\%) {

  my ($declination, $latitude, $limitsref) = @_;

  # Check that all the required keys are present
  if ((!exists $limitsref->{XLOW}) || (!exists $limitsref->{XLOW_KEYHOLE}) ||

  The returned value is :
    $tlos        - The time left on-source (turns)

=cut

sub ewxy_tlos($$$\%) {

  my ($hour_angle, $declination, $latitude, $limitsref) = @_;

  my $haset = haset_ewxy($declination, $latitude, %$limitsref);
  return(undef) if (!defined $haset);


  NOTE: returns undef if the %limits hash is missing any of the required keys

=cut

sub haset_azel($$\%) {

  my ($declination,  $latitude, $limitsref) = @_;

  # Check that all the required keys are present
  if (!exists $limitsref->{ELLOW}) {

  The returned value is :
    $tlos        - The time left on-source (turns)

=cut

sub azel_tlos($$$\%) {
  my ($hour_angle, $declination, $latitude, $limitsref) = @_;

  # Calculate the time left onsource
  my $haset = haset_azel($declination, $latitude, %$limitsref);
  if (!defined $haset) {return(undef)};

               angle at which the source rises is simply the negative of this
               value.

=cut

sub antenna_rise($$$$) {

  my ($declination, $latitude, $mount, $limitsref) = @_;

  # Check that the mount type is either EWXY (0) or AZEL (1)
  if (($mount != 0) && ($mount != 1)) {


#my @b2g = ([ -0.0548777621, +0.4941083214, -0.8676666398],
#	   [ -0.8734369591, -0.4448308610, -0.1980741871],
#	   [ -0.4838350026, +0.7469822433, +0.4559837919]);

sub j2gal($$) {
  my ($ra,$dec) = @_;
  my @r = pol2r($ra,$dec);
  my @g = (0,0,0);
  for (my $i=0; $i<3; $i++) {
    for (my $j=0; $j<3; $j++) {

view all matches for this distribution

Async-Chain

1 match

lib/Async/Chain.pm view on Meta::CPAN

Only one exported subroutine. Create and call Anync::Chain object. Return empty
list.

=cut

sub chain(@) {
	my $self = __PACKAGE__->new(@_);
	$self->();
	();
}

view all matches for this distribution

Async-ContextSwitcher

1 match

lib/Async/ContextSwitcher.pm view on Meta::CPAN

    my $ct = context->{request}{HTTP_CONTENT_TYPE};
    context->{user} = $user;

=cut

sub context() {
    return $CTX if $CTX;
    return $CTX = __PACKAGE__->new;
}

=head2 cb_w_context

lib/Async/ContextSwitcher.pm view on Meta::CPAN

Make sure that all callbacks in your code are created with this function
or you can loose track of your context.

=cut

sub cb_w_context(&) {
    my $cb = $_[0];
    my $ctx = $CTX;
    return sub {
        $CTX = $ctx;
        goto &$cb;

view all matches for this distribution

Async-Trampoline

1 match

t/lib/Async/Trampoline/Describe.pm view on Meta::CPAN

        ...
    };

=cut

sub describe($&) {
    my ($what, $test) = @_;
    local $_PATH = (defined $_PATH) ? "$_PATH\::$what" : $what;
    @_ = ($_PATH, $test);
    goto &subtest;
}

t/lib/Async/Trampoline/Describe.pm view on Meta::CPAN

        ...
    };

=cut

sub it($&) {
    my ($behaves, $test) = @_;
    local $_PATH = (defined $_PATH) ? "$_PATH $behaves" : "it $behaves";
    @_ = ($_PATH, $test);
    goto &subtest;
}

view all matches for this distribution

At

1 match

t/04_at_did.t view on Meta::CPAN

#
use At::Protocol::DID qw[:all];
#
imported_ok qw[ensureValidDid ensureValidDidRegex];
#
sub expectValid($uri) {
    subtest $uri => sub {
        ok ensureValidDid($uri),      'ensureValidDid( ... )';
        ok ensureValidDidRegex($uri), 'ensureValidDidRegex( ... )';
    }
}

sub expectInvalid($uri) {
    subtest $uri => sub {
        ok dies { ensureValidDid($uri) },        'ensureValidDid( ... ) dies';
        ok dies { ensureValidAtDidRegex($uri) }, 'ensureValidAtDidRegex( ... ) dies';
    }
}

view all matches for this distribution

Attribute-Boolean

1 match

lib/Attribute/Boolean/Value.pm view on Meta::CPAN

use Carp;

our $VERSION = version->declare('v1.0.7');
our @EXPORT = qw(true false);

sub true();
sub false();

use overload
   "0+"    => sub { ${$_[0]} },
   "bool"  => sub { ${$_[0]} },
   '""'    => sub { ${$_[0]} ? 'true' : 'false'},

lib/Attribute/Boolean/Value.pm view on Meta::CPAN

   ;

my $true  = do { bless \(my $dummy = 1), __PACKAGE__ };
my $false = do { bless \(my $dummy = 0), __PACKAGE__ };

sub true()  { $true  }
sub false() { $false }

sub TO_JSON($) {
    return $_[0] ? \1 : \0;
}

1;

view all matches for this distribution

Attribute-Default

1 match

lib/Attribute/Default.pm view on Meta::CPAN

## One specifies an expanding subroutine for Default by saying 'exsub
## { YOUR CODE HERE }'. It's run and used as a default at runtime.
##
## Exsubs are marked by being blessed into EXSUB_CLASS.
##
sub exsub(&) {
  my ($sub) = @_;
  ref $sub eq 'CODE' or die "Sub '$sub' can't be blessed: must be CODE ref";
  bless $sub, EXSUB_CLASS;
}

view all matches for this distribution

Attribute-Generator

2 results

    $default_object ||= $default_class->new;
    return $default_object;
}

my $import_called = 0;
sub import() {
    $import_called = 1;
    my $class = (grep /^-base$/i, @_) 
    ? scalar(caller)
    : $_[0];
    if (not defined $default_class) {

        $caller =~ s/.*:://;
        croak "Too late to call $caller()"
    }
}

sub find_my_self() {
    my $self = ref($_[0]) eq $default_class
    ? splice(@_, 0, 1)
    : default_object();
    return $self, @_;
}

sub blocks() {
    (my ($self), @_) = find_my_self(@_);

    croak "Invalid arguments passed to 'blocks'"
      if @_ > 1;
    croak sprintf("'%s' is invalid argument to blocks()", shift(@_))

    }

    return (@blocks);
}

sub next_block() {
    (my ($self), @_) = find_my_self(@_);
    my $list = $self->_next_list;
    if (@$list == 0) {
        $list = [@{$self->block_list}, undef];
        $self->_next_list($list);

        $block->run_filters;
    }
    return $block;
}

sub first_block() {
    (my ($self), @_) = find_my_self(@_);
    $self->_next_list([]);
    $self->next_block;
}

sub filters_delay() {
    (my ($self), @_) = find_my_self(@_);
    $self->_filters_delay(defined $_[0] ? shift : 1);
}

sub no_diag_on_only() {
    (my ($self), @_) = find_my_self(@_);
    $self->_no_diag_on_only(defined $_[0] ? shift : 1);
}

sub delimiters() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    my ($block_delimiter, $data_delimiter) = @_;
    $block_delimiter ||= $self->block_delim_default;
    $data_delimiter ||= $self->data_delim_default;
    $self->block_delim($block_delimiter);
    $self->data_delim($data_delimiter);
    return $self;
}

sub spec_file() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_file(shift);
    return $self;
}

sub spec_string() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_string(shift);
    return $self;
}

sub filters() {
    (my ($self), @_) = find_my_self(@_);
    if (ref($_[0]) eq 'HASH') {
        $self->_filters_map(shift);
    }
    else {

        push @$filters, @_;
    }
    return $self;
}

sub filter_arguments() {
    $Test::Base::Filter::arguments;
}

sub have_text_diff {
    eval { require Text::Diff; 1 } &&
        $Text::Diff::VERSION >= 0.35 &&
        $Algorithm::Diff::VERSION >= 1.15;
}

sub is($$;$) {
    (my ($self), @_) = find_my_self(@_);
    my ($actual, $expected, $name) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    if ($ENV{TEST_SHOW_NO_DIFFS} or
         not defined $actual or

        ok $actual eq $expected,
           $name . "\n" . Text::Diff::diff(\$expected, \$actual);
    }
}

sub run(&;$) {
    (my ($self), @_) = find_my_self(@_);
    my $callback = shift;
    for my $block (@{$self->block_list}) {
        $block->run_filters unless $block->is_filtered;
        &{$callback}($block);


sub END {
    run_compare() unless $Have_Plan or $DIED or not $import_called;
}

sub run_compare() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

            is($block->$x, $block->$y, $block->name ? $block->name : ());
        }
    }
}

sub run_is() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

           $block->name ? $block->name : ()
          );
    }
}

sub run_is_deeply() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and exists($block->{$y});

           $block->name ? $block->name : ()
          );
    }
}

sub run_like() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

             $block->name ? $block->name : ()
            );
    }
}

sub run_unlike() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

        };
    }
    return $spec;
}

sub _strict_warnings() {
    require Filter::Util::Call;
    my $done = 0;
    Filter::Util::Call::filter_add(
        sub {
            return 0 if $done;

            $done = 1;
        }
    );
}

sub tie_output() {
    my $handle = shift;
    die "No buffer to tie" unless @_;
    tie $handle, 'Test::Base::Handle', $_[0];
}

    $ENV{TEST_SHOW_NO_DIFFS} = 1;
}

package Test::Base::Handle;

sub TIEHANDLE() {
    my $class = shift;
    bless \ $_[0], $class;
}

sub PRINT {


sub AUTOLOAD {
    return;
}

sub block_accessor() {
    my $accessor = shift;
    no strict 'refs';
    return if defined &$accessor;
    *$accessor = sub {
        my $self = shift;

view all matches for this distribution

Attribute-Handlers-Clean

1 match

lib/Attribute/Handlers/Clean.pm view on Meta::CPAN

}

my $builtin = qr/lvalue|locked|unique|shared/; # Method left out on purpose.


sub _gen_handler_AH_() {
    sub {
        _resolve_lastattr if _delayed_name_resolution;
        my ($pkg, $ref, @attrs) = @_;
        push @attrs, attributes::get($ref);
        Perlmazing::remove_duplicates(@attrs);

view all matches for this distribution

Attribute-Handlers

1 match

lib/Attribute/Handlers.pm view on Meta::CPAN

	croak "Attribute handler '$2' doesn't handle $1 attributes";
}

my $builtin = qr/lvalue|method|locked|unique|shared/;

sub _gen_handler_AH_() {
	return sub {
	    _resolve_lastattr if _delayed_name_resolution;
	    my ($pkg, $ref, @attrs) = @_;
	    my (undef, $filename, $linenum) = caller 2;
	    foreach (@attrs) {

view all matches for this distribution

Attribute-Lexical

2 results

lib/Attribute/Lexical.pm view on Meta::CPAN

	}
}."}
	1;
" or die $@; }

sub _check_attribute_name($) {
	croak "attribute name must be a string" unless is_string($_[0]);
	croak "malformed attribute name" unless $_[0] =~ qr/\A
		(?:SCALAR|ARRAY|HASH|CODE):
		[A-Za-z_][0-9A-Za-z_]*
	\z/x;

view all matches for this distribution

Attribute-Overload-Match

1 match

test.pl view on Meta::CPAN

no warnings 'redefine';

BEGIN { use_ok('Attribute::Overload::Match'); }
require_ok('Attribute::Overload::Match');

sub new($)               { my $x = $_[0]; bless \$x, __PACKAGE__ }
sub val($)               { ${$_[0]} }
sub eq       : op(==)    { val(shift) == shift }
sub subtract : op(-)     { new val(shift) - shift }
sub mul      : op(*)     { new val(shift) * shift }
sub add      : op(+)     { new val(shift) + shift }
sub div      : op(+)     { new val(shift) / shift }

view all matches for this distribution

Attribute-Property

1 match

t/lib/Test/More.pm view on Meta::CPAN


    cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );

=cut

sub cmp_ok($$$;$) {
    $Test->cmp_ok(@_);
}


=item B<can_ok>

view all matches for this distribution

Attribute-Types

2 results

lib/Attribute/Types.pm view on Meta::CPAN

		$attr{$_}++;
	}
}


sub verify(&) {
	use warnings 'all';
	local $^W = 1;
	my $fail = 0;
	local $SIG{__WARN__} = sub { $fail=1 };
	return eval { $_[0]->() && !$fail };

view all matches for this distribution

Audio-ConvTools

3 results


BEGIN {
	#$Exporter::Verbose = 1
};

sub getVersion()
{
	return $VERSION;
}

sub getNowTxt()
{
	my ($s, $m, $h, $D, $M, $Y) = localtime(time);
	return sprintf(
		"%04d-%02d-%02d %02d:%02d:%02d",
		$Y+1900, $M+1, $D, $h, $m, $s
	);
}

sub logMsg($)
{
	my $txt = shift;
	print STDERR getNowTxt() . ": INFO: " . $txt . $/;
}

sub errMsg($)
{
	my $txt = shift;
	print STDERR getNowTxt() . ": ERROR: " . $txt . $/;
}

sub getTmpFile($)
{
	my $extension = shift;
	my $tmp = new File::Temp(
		SUFFIX=>$extension,
		UNLINK=>1         , #to automatically remove when out of scope
	);
	return $tmp;
}

sub destroyTmpFile($)
{
	my $pTmp = shift;
	$$pTmp->cleanup(); #to be sure
	$$pTmp = undef; #old tmp object is out of scope => automatically cleaned
}

sub mp32ogg($)
{
	my $inFile = shift;
	my $outFile;
	my $tmpFile;
	my $status;

	destroyTmpFile(\$tmpFile);

	return $status;
}

sub ogg2mp3($)
{
	my $inFile = shift;
	my $outFile;
	my $tmpFile;
	my $status;

	destroyTmpFile(\$tmpFile);

	return $status;
}

sub mp32wav($;$)
{
	my $inFile = shift;
	my $outFile = shift;
	my $status;
	($inFile =~ /^(.*)\.[Mm][Pp]3$/) or do {

		"mpg321 -w " . shell_quote($outFile) . " " . shell_quote($inFile)
	);
	return ($status==0);
}

sub ogg2wav($;$)
{
	my $inFile = shift;
	my $outFile = shift;
	my $status;
	($inFile =~ /^(.*)\.[Oo][Gg][Gg]$/) or do {

		"oggdec " . shell_quote($inFile) . " -o " . shell_quote($outFile)
	);
	return ($status==0);
}

sub wav2ogg($;$)
{
	my $inFile = shift;
	my $outFile = shift;
	my $status;
	($inFile =~ /^(.*)\.[Ww][Aa][Vv]$/) or do {

		"oggenc -q 10 -o " . shell_quote($outFile) . " " . shell_quote($inFile)
	);
	return ($status==0);
}

sub wav2mp3($;$)
{
	my $inFile = shift;
	my $outFile = shift;
	my $status;
	($inFile =~ /^(.*)\.[Ww][Aa][Vv]$/) or do {

view all matches for this distribution

Audio-FindChunks

1 match

FindChunks.pm view on Meta::CPAN

		    }
		    return read_averages($s);
		}},
  );

sub __s_size() {length pack "d2 ${long}2", 0, 0, 0, 0}

sub read_averages ($) {
  my $self = shift;
  my $fh = $self->get('fh_bin');
  my $vals = {};

view all matches for this distribution

Audio-Play-MPG123

1 match

mpg123sh view on Meta::CPAN

$p_repeat;

$player = new Audio::Play::MPG123 mpg123args => ["-b4096"];

# do uri-style escaping PLUS escape space to · and back (sorry for that :()
sub uri_esc($) {
   local $_ = shift;
   s/([^\x21-\x24\x26-\x7e\xa0-\xb6\xb8-\xff])/sprintf "%c%02x", 0x25, ord($1)/ge;
   s/%20/·/g;
   $_;
}

sub uri_unesc($) {
   local $_ = shift;
   s/·/%20/g;
   s/%([0-9a-f][0-9a-f])/chr(hex($1))/gei;
   $_;
}

mpg123sh view on Meta::CPAN

      mp3log("+", $p_url);
      $player->stat;
   }
}

sub add_url($) {
   my $url = shift;
   push @playlist, [$url, 1];
   next_song unless $player->state;
   mp3log("a", $url);
}

view all matches for this distribution

Audio-Radio-V4L

1 match

 Argument  : none

=cut

################################################## subroutine header end ##
sub new() {
	my $class = shift;
	my $self  = bless {}, $class;
	$self;
}

 Throws    : croaks on problems

=cut

################################################## subroutine header end ##
sub open() {
	my $self = shift;
	my $devicename = shift || "/dev/radio";
	my $devicenumber = shift;
	(defined $devicenumber) || ($devicenumber = 0);
	$self->{ _devicenumber } = $devicenumber;

		or croak "Could not open radio $devicename: $!";
	$self->_initialize_values_from_device();
	$self;
}

sub _initialize_values_from_device() {
	my $self = shift;
	# struct from linux/videodev.h
	my $videotuner = pack("iZ32LLLss",$self->{ _devicenumber },"",0,0,0,0);
	ioctl( 
		$self->{ _fh },

 Argument  : none

=cut

################################################## subroutine header end ##
sub get_devicename() {
	my $self = shift;
	$self->{ _fh } or croak "No device opened!";
	$self->{ _devicename };
}

 Argument  : none

=cut

################################################## subroutine header end ##
sub get_freq_min() {
	my $self = shift;
	$self->{ _fh } or croak "No device opened!";
	$self->{ _rangelow } / $self->_get_frequency_factor();
}

 Argument  : none

=cut

################################################## subroutine header end ##
sub get_freq_max() {
	my $self = shift;
	$self->{ _fh } or croak "No device opened!";
	$self->{ _rangehigh } / $self->_get_frequency_factor();
}

 Throws    : croaks on problems

=cut

################################################## subroutine header end ##
sub close() {
	my $self = shift;
	croak "No radio to close" unless $self->{ _fh };
	close( $self->{ _fh } )
		or croak "Could not close radio: $!";
	delete $self->{ _fh };

 Argument  : the frequency in khz

=cut

################################################## subroutine header end ##
sub set_frequency() {
	my $self = shift;
	my $frequency = shift;
	croak "Open the radio first!" unless $self->{ _fh };
	ioctl( 
		$self->{ _fh },

	)
		or croak "Could not set frequency: $!";
	$self;
}

sub _get_VIDIOCSFREQ() {
	return  0x4004760f;
	# return __get_VIDIOCSFREQ();
}

#use Inline C => <<'END_OF_C';

#			return VIDIOCSFREQ;
#		}
#	
#END_OF_C

sub _get_VIDIOCGTUNER() {
	return 0xC0347604;
	# return __get_VIDIOCGTUNER();
}

#use Inline C => <<'END_OF_C';

#			return VIDIOCGTUNER;
#		}
#	
#END_OF_C

sub _get_VIDEO_TUNER_LOW() {
	return 8;
	# return __get_VIDEO_TUNER_LOW;
}

#use Inline C => <<'END_OF_C';

#			return VIDEO_TUNER_LOW;
#		}
#	
#END_OF_C

sub _get_frequency_factor() {
	my $self = shift;
	$self->{ _deviceflags } & _get_VIDEO_TUNER_LOW() ?
		16
	:	.016;
}

view all matches for this distribution

Audio-SID

1 match

    }

    return $self;
}

sub initialize() {
    my ($self) = $_[0];

    # Initial SID data.
    $self->{SIDdata} = {
        magicID => 'RSID',

    }

    return $REAL_LOAD_ADDRESS;
}

sub getSpeed($) {
    my ($self, $songnumber) = @_;

    $songnumber = 1 if ((!defined($songnumber)) or ($songnumber < 1));

    if ($songnumber > $self->{SIDdata}{songs}) {

    }

    return $SIDModel;
}

sub getSIDAddress($) {
    my ($self, $sidNumber) = @_;
    my $SIDAddressMiddle;
    my $fullSIDAddress;

    if (!defined($sidNumber) or ($sidNumber == 1)) {

    
    return $fullSIDAddress;
}

# Notice that you have to pass in a hash (field-value pairs)!
sub set(@) {
    my ($self, %SIDhash) = @_;
    my $fieldname;
    my $paddinglength;
    my $i;
    my $version;

        length($self->{SIDdata}{data});

    return 1;
}

sub setFileName($) {
    my ($self, $filename) = @_;

    $self->{FILENAME} = $filename;
}

sub setSpeed($$) {
    my ($self, $songnumber, $value) = @_;

    unless (defined($songnumber)) {
        confess ("No song number was specified!");
        return undef;


    # Then set it.
    $self->{SIDdata}{speed} |= ($value << ($songnumber-1));
}

sub setMUSPlayer($) {
    my ($self, $MUSplayer) = @_;

    unless (defined($self->{SIDdata}{flags})) {
        confess ("Cannot set this field when SID version is 1!");
        return undef;


    # Then set it.
    $self->{SIDdata}{flags} |= ($MUSplayer << $MUSPLAYER_OFFSET);
}

sub setPlaySID($) {
    my ($self, $PlaySID) = @_;

    if ($self->isRSID() ) {
        confess ("Cannot set this field for RSID!");
        return undef;


    # Then set it.
    $self->{SIDdata}{flags} |= ($PlaySID << $PLAYSID_OFFSET);
}

sub setC64BASIC($) {
    my ($self, $C64BASIC) = @_;

    unless ($self->isRSID() ) {
        confess ("Cannot set this field for PSID!");
        return undef;

    if ($C64BASIC) {
        $self->{SIDdata}{initAddress} = 0;
    }
}

sub setClock($) {
    my ($self, $clock) = @_;

    unless (defined($self->{SIDdata}{flags})) {
        confess ("Cannot set this field when SID version is 1!");
        return undef;


    # Then set them.
    $self->{SIDdata}{flags} |= ($clock << $CLOCK_OFFSET);
}

sub setClockByName($) {
    my ($self, $clock) = @_;

    unless (defined($self->{SIDdata}{flags})) {
        confess ("Cannot set this field when SID version is 1!");
        return undef;

    }

    $self->setClock($clock);
}

sub setSIDModel($) {
    my ($self, $SIDModel, $sidNumber) = @_;

    unless (defined($self->{SIDdata}{flags})) {
        confess ("Cannot set this field when SID version is 1!");
        return undef;

        # Then set them.
        $self->{SIDdata}{flags} |= ($SIDModel << $THIRD_SIDMODEL_OFFSET);
    }
}

sub setSIDModelByName($) {
    my ($self, $SIDModel, $sidNumber) = @_;

    unless (defined($self->{SIDdata}{flags})) {
        confess ("Cannot set this field when SID version is 1!");
        return undef;

    }

    return $self->setSIDModel($SIDModel, $sidNumber);
}

sub setSIDAddress($) {
    my ($self, $sidNumber, $fullSIDAddress) = @_;
    
    if (!defined($sidNumber) or ($sidNumber < 2) or ($sidNumber > 3)) {
        confess("Invalid SID number: '$sidNumber'!");
        return undef;

    }

    return ($md5->hexdigest);
}

sub alwaysValidateWrite($) {
    my ($self, $setting) = @_;

    $self->{validateWrite} = $setting;
}

view all matches for this distribution

Audio-Scrobbler

2 results


our @ISA = qw();

our $VERSION = '0.01';

sub err($ $);
sub handshake($);

sub get_ua($);

sub URLEncode($);
sub URLDecode($);

=head1 METHODS

The C<Audio::Scrobbler> class defines the following methods:

Retrieves or sets the description of the last error encountered in
the operation of this C<Audio::Scrobbler> object.

=cut

sub err($ $)
{
	my ($self, $err) = @_;

	$self->{'err'} = $err if $err;
	return $self->{'err'};

If the B<verbose> configuration parameter is set, the L<handshake>
method reports its progress with diagnostic messages to the standard output.

=cut

sub handshake($)
{
	my ($self) = @_;
	my ($ua, $req, $resp, $c, $s);
	my (@lines);

If the B<verbose> configuration parameter is set, the L<submit>
method reports its progress with diagnostic messages to the standard output.

=cut

sub submit($ \%)
{
	my ($self, $info) = @_;
	my ($ua, $req, $resp, $s, $c, $datestr, $md5resp);
	my (@t, @lines);

Creates or returns the cached C<LWP::UserAgent> object used by
the C<Audio::Scrobbler> class for access to the AudioScrobbler API.

=cut

sub get_ua($)
{
	my ($self) = @_;
	my ($ua);

	$self->{'ua'} ||= new LWP::UserAgent();


Obtained from http://glennf.com/writing/hexadecimal.url.encoding.html

=cut

sub URLDecode($) {
	my $theURL = $_[0];
	$theURL =~ tr/+/ /;
	$theURL =~ s/%([a-fA-F0-9]{2,2})/chr(hex($1))/eg;
	$theURL =~ s/<!--(.|\n)*-->//g;
	return $theURL;


Obtained from http://glennf.com/writing/hexadecimal.url.encoding.html

=cut

sub URLEncode($) {
	my $theURL = $_[0];
	$theURL =~ s/([^a-zA-Z0-9_])/'%' . uc(sprintf("%2.2x",ord($1)));/eg;
	return $theURL;
}

view all matches for this distribution

Audio-TagLib

1 match

Makefile.PL view on Meta::CPAN

use ExtUtils::MakeMaker;
use Config;
use English;
use version 0.77;

sub bail($) {
    my $reason = shift;
    warn $reason;
    exit(0);
}

view all matches for this distribution

Audit-Log

1 match

lib/Audit/Log.pm view on Meta::CPAN

    }
    close($fh);
    return $ret;
}

sub file_changes(&@) {
    my ( $block, @dirs ) = @_;
    my %rules;

    # Instruct auditctl to add UUID based rules
    foreach my $dir (@dirs) {

view all matches for this distribution

Authen-CAS-UserAgent

1 match

};

##Static Methods

#return the default user agent for this class
sub _agent($) {
	return
		$_[0]->SUPER::_agent . ' ' .
		'CAS-UserAgent/' . $VERSION;
}

#Constructor
sub new($%) {
	my $self = shift;
	my (%opt) = @_;

	# remove any cas options before creating base object
	my $cas_opts = delete $opt{'cas_opts'};

#	proxy             => a boolean indicating this handler is a proxy login handler
#	restful           => a boolean indicating if the CAS server supports the RESTful API
#	callback          => a login callback to use for logging into CAS, it should return a ticket for the specified service
#	ticket_heuristics => an array of heuristic callbacks that are performed when searching for the service and ticket in a CAS response
#	strict            => only allow CAS login when the service is the same as the original url
sub attach_cas_handler($%) {
	my $self = shift;
	my (%opt) = @_;

	#short-circuit if required options aren't specified
	return if(!exists $opt{'server'});

	);

	return 1;
}

sub get_cas_handlers($;$) {
	my $self = shift;
	my ($server) = @_;

	$server = URI->new($server . ($server =~ /\/$/o ? '' : '/'))->canonical if(defined $server);
	return $self->get_my_handler('response_done',

		(defined $server ? ('casServer' => $server) : ()),
	);
}

# method that will retrieve a ticket for the specified service
sub get_cas_ticket($$;$) {
	my $self = shift;
	my ($service, $server) = @_;

	# resolve which handler to use
	my $h;

	# return the found ticket
	return $ticket;
}

#method that will remove the cas login handlers for the specified cas servers or all if a specified server is not provided
sub remove_cas_handlers($@) {
	my $self = shift;

	#remove cas login handlers for any specified cas servers
	$self->remove_handler('response_done',
		'owner' => CASHANDLERNAME,

view all matches for this distribution

Authen-DecHpwd

1 match

);
use Scalar::String 0.000 qw(sclstr_is_downgraded sclstr_downgraded);

my $u32_mask = 0xffffffff;

sub _u32_shl($$) {
	if(natint_bits == 32) {
		return &uint_shl;
	} else {
		return uint_and(&uint_shl, $u32_mask);
	}


*_u32_shr = \&uint_shr;

*_u32_and = \&uint_and;

sub _u32_rol($$) {
	if(natint_bits == 32) {
		return &uint_rol;
	} else {
		return $_[0] if $_[1] == 0;
		return uint_and(uint_or(uint_shl($_[0], $_[1]),
					uint_shr($_[0], 32-$_[1])),
				$u32_mask);
	}
}

sub _u32_madd($$) { uint_and(&uint_madd, $u32_mask) }

sub _u32_cadd($$$) {
	if(natint_bits == 32) {
		return &uint_cadd;
	} else {
		my(undef, $val) = uint_cadd($_[0], $_[1], $_[2]);
		return (uint_and(uint_shr($val, 32), 1),

	}
}

my $u16_mask = 0xffff;

sub _u16_madd($$) { uint_and(&uint_madd, $u16_mask) }

my $u8_mask = 0xff;

sub _u8_madd($$) { uint_and(&uint_madd, $u8_mask) }

sub _addUnalignedWord($$) {
	$_[0] = pack("v", _u16_madd(unpack("v", $_[0]), $_[1]));
}

use constant _PURDY_USERNAME_LENGTH => 12;

use constant _C2 => pack("VV", 0xffffff4d, 0xffffffff);
use constant _C3 => pack("VV", 0xfffffeff, 0xffffffff);
use constant _C4 => pack("VV", 0xfffffebd, 0xffffffff);
use constant _C5 => pack("VV", 0xfffffe95, 0xffffffff);

sub _PQMOD_R0($) {
	my($low, $high) = unpack("VV", $_[0]);
	if($high == _P_D_HIGH && $low >= _P_D_LOW) {
		$_[0] = pack("VV", _u32_madd($low, _A), 0);
	}
}

sub _ROL1($) { $_[0] = pack("V", _u32_rol(unpack("V", $_[0]), 1)); }

sub _QROL1($) {
	_ROL1(substr($_[0], 0, 4));
	_ROL1(substr($_[0], 4, 4));
}

sub _EMULQ($$$) {
	my($a, $b, undef) = @_;
	my $hi = _u32_shr($a, 16) * _u32_shr($b, 16);
	my $lo = _u32_and($a, 0xffff) * _u32_and($b, 0xffff);
	my $carry;
	my $p = _u32_shr($a, 16) * _u32_and($b, 0xffff);

	($carry, $lo) = _u32_cadd($lo, _u32_shl($p, 16), 0);
	($carry, $hi) = _u32_cadd($hi, _u32_shr($p, 16), $carry);
	$_[2] = pack("VV", $lo, $hi);
}

sub _PQADD_R0($$$) {
	my($u, $y, undef) = @_;
	my($ulo, $uhi) = unpack("VV", $u);
	my($ylo, $yhi) = unpack("VV", $y);
	my($carry, $rlo, $rhi);
	($carry, $rlo) = _u32_cadd($ulo, $ylo, 0);

		($carry, $rhi) = _u32_cadd($rhi, 0, $carry);
	}
	$_[2] = pack("VV", $rlo, $rhi);
}

sub _COLLAPSE_R2($$$) {
	my($s, undef, $isPurdyS) = @_;
	for(my $p = length($s); $p != 0; $p--) {
		my $pp = $p & _MASK;
		substr($_[1], $pp, 1) = pack("C",
			_u8_madd(unpack("C", substr($_[1], $pp, 1)),
				unpack("C", substr($s, -$p, 1))));
		if($isPurdyS && $pp == _MASK) { _QROL1($_[1]); }
	}
}

sub _PQLSH_R0($$) {
	my($u, undef) = @_;
	my($ulo, $uhi) = unpack("VV", $u);
	my $stack = pack("VV", 0, 0);
	my $x = pack("VV", 0, 0);
	_EMULQ($uhi, _A, $stack);
	$x = pack("VV", 0, $ulo);
	_PQADD_R0($x, $stack, $_[1]);
}

sub _PQMUL_R2($$$) {
	my($u, $y, undef) = @_;
	my($ulo, $uhi) = unpack("VV", $u);
	my($ylo, $yhi) = unpack("VV", $y);
	my $stack = pack("VV", 0, 0);
	my $part1 = pack("VV", 0, 0);

	_PQLSH_R0($stack, $part1);
	_EMULQ($ulo, $ylo, $stack);
	_PQADD_R0($part1, $stack, $_[2]);
}

sub _PQEXP_R3($$$) {
	my($u, $n, undef) = @_;
	my $y = pack("VV", 0, 0);
	my $z = pack("VV", 0, 0);
	my $z1 = pack("VV", 0, 0);
	my $yok = 0;

		_PQMUL_R2($z1, $z1, $z);
	}
	$_[2] = pack("VV", 1, 0);
}

sub _Purdy($) {
	my $t1 = pack("VV", 0, 0);
	my $t2 = pack("VV", 0, 0);
	my $t3 = pack("VV", 0, 0);

	_PQEXP_R3($_[0], _Na, $t1);

	_PQADD_R0($t1, _C5, $_[0]);

	_PQMOD_R0($_[0]);
}

sub lgi_hpwd($$$$) {
	my($username, $password, $alg, $salt) = @_;
	if($alg > UAI_C_PURDY_S) {
		die "algorithm value $alg is not recognised";
	}
	$salt = uint_and($salt, 0xffff);

correct username syntax then the username is returned in canonical form
(uppercase).  If the string is not a username then C<undef> is returned.

=cut

sub vms_username($) {
	return $_[0] =~ /\A[_\$0-9A-Za-z]{1,31}\z/ ? uc("$_[0]") : undef;
}

=item vms_password(PASSWORD)

(uppercase).  If the string is not an acceptable password then C<undef>
is returned.

=cut

sub vms_password($) {
	return $_[0] =~ /\A[_\$0-9A-Za-z]{1,32}\z/ ? uc("$_[0]") : undef;
}

=back

view all matches for this distribution

Authen-DigestMD5

1 match

DigestMD5.pm view on Meta::CPAN

use strict;
use warnings;

my %quote=map{$_=>1} qw(username realm nonce cnonce digest-uri qop cipher);

sub _quote($$) {
    shift;
    my ($k, $v)=@_;
    return () unless defined $v;
    if ($quote{$k}) {
	$v =~ s/([\\"])/\\$1/g;

view all matches for this distribution

Authen-Htpasswd-Trac

1 match

inc/Test/More.pm view on Meta::CPAN

}


#line 424

sub cmp_ok($$$;$) {
    my $tb = Test::More->builder;

    $tb->cmp_ok(@_);
}

view all matches for this distribution

Authen-Krb5-Easy

1 match

Easy.pm view on Meta::CPAN


bootstrap Authen::Krb5::Easy $VERSION;

# Preloaded methods go here.

sub kexpired()
{
	return kexpires() < time() ? 1 : 0;
}

sub kerror()
{
	return "" . get_error_while_doing() . ": " . get_error_string() . "\n";
}

sub kcheck($$)
{
	my($keytab, $princ) = @_;

	if(kexpired())
	{

view all matches for this distribution

Authen-Krb5

1 match