├── .gitignore
├── bugs
    ├── autodie.pl
    ├── file_spec.pl
    ├── utf8.pl
    ├── feature-5_10.pl
    ├── hires
    │   ├── hires.pl
    │   └── hires_on_horizontal_progress.pl
    └── lastlocation_horizontal.pl
├── scriptlets
    ├── 01_hello_world.pl
    ├── MyTools.pl
    ├── vibrate.pl
    ├── speak.pl
    ├── getinput.pl
    ├── 02_android_object.pl
    ├── sensing_location.pl
    ├── location.pl
    ├── dialog_dismiss.pl
    ├── airplane.pl
    ├── gps.pl
    ├── info.pl
    ├── spinning_progress.pl
    ├── horizontal_progress.pl
    ├── alert_dialog.pl
    ├── ringer_silent_mode.pl
    └── get.pl
├── README
├── examples
    ├── del_messages.pl
    ├── plack.pl
    ├── sms_search.pl
    └── gps_send_message.pl
├── COMPILING
├── test.pl
├── Android.pm
└── modules
    └── Try
        └── Tiny.pm


/.gitignore:
--------------------------------------------------------------------------------
1 | *.swp
2 | 


--------------------------------------------------------------------------------
/bugs/autodie.pl:
--------------------------------------------------------------------------------
1 | use autodie;
2 | 


--------------------------------------------------------------------------------
/bugs/file_spec.pl:
--------------------------------------------------------------------------------
1 | use File::Spec;
2 | 
3 | 


--------------------------------------------------------------------------------
/bugs/utf8.pl:
--------------------------------------------------------------------------------
1 | use strict;
2 | use warnings;
3 | 
4 | use utf8;
5 | 
6 | utf8::encode("täxt");
7 | 
8 | 
9 | 


--------------------------------------------------------------------------------
/bugs/feature-5_10.pl:
--------------------------------------------------------------------------------
1 | # checks that feature.pm is unavailable
2 | use 5.010;
3 | say "hello Android";
4 | 
5 | 


--------------------------------------------------------------------------------
/scriptlets/01_hello_world.pl:
--------------------------------------------------------------------------------
1 | 
2 | use strict;
3 | use warnings;
4 | 
5 | use Android;
6 | my $d = Android->new();
7 | $d->makeToast("Hello, Android!");
8 | 


--------------------------------------------------------------------------------
/scriptlets/MyTools.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | use Data::Dumper;
 5 | 
 6 | sub dd {
 7 |     print Dumper shift;
 8 | }
 9 | sub say {
10 | 	print @_, "\n";
11 | }
12 | 
13 | 1;
14 | 
15 | 


--------------------------------------------------------------------------------
/scriptlets/vibrate.pl:
--------------------------------------------------------------------------------
 1 | 
 2 | use strict;
 3 | use warnings;
 4 | 
 5 | require "/sdcard/ase/scripts/MyTools.pl";
 6 | 
 7 | use Android;
 8 | my $d = Android->new();
 9 | 
10 | dd($d->vibrate(10000));
11 | 
12 | say("done");
13 | 
14 | 


--------------------------------------------------------------------------------
/scriptlets/speak.pl:
--------------------------------------------------------------------------------
 1 | 
 2 | use strict;
 3 | use warnings;
 4 | 
 5 | require "/sdcard/ase/scripts/MyTools.pl";
 6 | 
 7 | use Android;
 8 | my $d = Android->new();
 9 | 
10 | dd($d->speak("hello Android from Perl"));
11 | 
12 | say("done");
13 | 
14 | 


--------------------------------------------------------------------------------
/scriptlets/getinput.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | use Android;
 7 | my $d = Android->new();
 8 | 
 9 | dd($d->getInput("title", "text"));
10 | 
11 | # The 'result' will contain the string the user typed in
12 | 


--------------------------------------------------------------------------------
/scriptlets/02_android_object.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | use Android;
 7 | 
 8 | my $d = Android->new();
 9 | say($d);      # HASH()
10 | dd($d);        # Android object { conn => Symbol::GEN, IO::Socket::INET, id => 0 }
11 | 
12 | 


--------------------------------------------------------------------------------
/bugs/hires/hires.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | use Time::HiRes 'sleep';
 5 | 
 6 | eval {
 7 |     local $SIG{'ALRM'} = sub { die "alarm\n" };
 8 |     alarm 1;
 9 |     print 'Sleep test... ';
10 | 
11 |     sleep 0.1;
12 |     alarm 0;
13 | };
14 | 
15 | if ($@) {
16 |     if ( $@ eq "alarm\n" ) {
17 |         print "FAIL\n";
18 |     }
19 | } else {
20 |     print "PASS\n";
21 | }
22 | 


--------------------------------------------------------------------------------
/scriptlets/sensing_location.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | use Android;
 7 | 
 8 | my $d = Android->new();
 9 | dd($d->startSensing);
10 | 
11 | my $l = $d->readLocation;
12 | dd($l);
13 | 
14 | # this gives the hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)
15 | dd($d->geocode(52.5, 13.5));
16 | 
17 | 


--------------------------------------------------------------------------------
/scriptlets/location.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | use Android;
 7 | 
 8 | my $d = Android->new();
 9 | my $loc =  $d->getLastKnownLocation();
10 | dd($loc);
11 | say($loc->{result}->{longitude});
12 | # fields  are provider, time, longitude, latitude, speed, accuracy, altitude
13 | # the provider is a string -  I got 'network' the others are numbers
14 | 


--------------------------------------------------------------------------------
/scriptlets/dialog_dismiss.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | use Android;
 7 | my $d = Android->new();
 8 | 
 9 | 
10 | dd($d->dialogCreateAlert("the title", "text"));
11 | dd($d->dialogShow);
12 | 
13 | say("Still running");
14 | sleep(3);
15 | 
16 | dd($d->dialogDismiss); #forcibly eliminate the dialog even if it was not clicked on
17 | 
18 | dd($d->dialogGetResponse);
19 | 
20 | 
21 | 


--------------------------------------------------------------------------------
/scriptlets/airplane.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | use Android;
 7 | my $d = Android->new();
 8 | 
 9 | 
10 | # Currently this script shuts down the emulator
11 | 
12 | # result is JSON::PP::Boolean
13 | #say($d->checkAirplaneMode->{result});   # is false or true
14 | #say($d->toggleAirplaneMode->{result});  # returns the new mode (false or true)
15 | #say $d->checkAirplaneMode->{result};
16 | 
17 | 
18 | 


--------------------------------------------------------------------------------
/scriptlets/gps.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | use Android;
 7 | my $d = Android->new();
 8 | dd($d->startLocating("fine", 600, 30)); #coarse
 9 | #dd($d->startSensing);
10 | for (1..20) {
11 | 
12 | 	my $loc;
13 |     print "READ LOCATION:\n";
14 |     dd($d->readLocation); 
15 |     print "LAST_KNOWN_LOCATION:\n";
16 |     dd($d->getLastKnownLocation());
17 | #$d->readSensors;
18 | 	#say("Long $loc->{result}->{longitude}  Lat: $loc->{result}->{latitude}");
19 | 	sleep 2;
20 | }
21 | 
22 | 


--------------------------------------------------------------------------------
/scriptlets/info.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | 
 7 | say("Perl version:  $]");  # reporting 5.010001
 8 | say("\$0 $0");             # /sdcard/ase/scripts/info.pl
 9 | 
10 | use File::Basename qw(dirname);
11 | say(dirname($0));   # /sdcard/ase/scripts
12 | 
13 | use Cwd;
14 | say("cwd: " . cwd);  # /    (IMHO should be /sdcard/ase/scripts, question asked on list)
15 | 
16 | say("Path to perl: $^X");   # /data/data/com.google.ase/perl/perl
17 | 
18 | #print `ls -l`;
19 | # works
20 | #
21 | #print "pwd: ", `pwd`;
22 | # Can't exec "pwd": Permission denied
23 | 
24 | 


--------------------------------------------------------------------------------
/scriptlets/spinning_progress.pl:
--------------------------------------------------------------------------------
 1 | 
 2 | use strict;
 3 | use warnings;
 4 | 
 5 | require "/sdcard/ase/scripts/MyTools.pl";
 6 | 
 7 | use Android;
 8 | my $d = Android->new();
 9 | 
10 | my $max = 32;
11 | 
12 | $d->dialogCreateSpinnerProgress(
13 |    "title",
14 |    "message",
15 |    $max,  # maximum progress (shows a number 0/$max)
16 |    0,   # boolean, cancellable (Bug: I don't see any difference if I set it to 1)
17 | );
18 | dd($d->dialogShow);
19 | my $n = 0;
20 | while ($n < $max) {
21 | 	sleep 1;
22 | 	$n += int rand 7;
23 | 	$n = $n > $max ? $max : $n;
24 | 	$d->dialogSetCurrentProgress($n);
25 | }
26 | 
27 | dd($d->dialogDismiss);
28 | 
29 | 
30 | 


--------------------------------------------------------------------------------
/scriptlets/horizontal_progress.pl:
--------------------------------------------------------------------------------
 1 | 
 2 | use strict;
 3 | use warnings;
 4 | 
 5 | require "/sdcard/ase/scripts/MyTools.pl";
 6 | 
 7 | use Android;
 8 | my $d = Android->new();
 9 | 
10 | my $max = 32;
11 | 
12 | $d->dialogCreateHorizontalProgress(
13 |    "title",
14 |    "message",
15 |    $max,  # maximum progress (shows a number 0/$max)
16 |    0,   # boolean, cancellable (Bug: I don't see any difference if I set it to 1)
17 | );
18 | dd($d->dialogShow);
19 | my $n = 0;
20 | while ($n < $max) {
21 | 	sleep 1;
22 | 	$n += int rand 7;
23 | 	$n = $n > $max ? $max : $n;
24 | 	$d->dialogSetCurrentProgress($n);
25 | }
26 | 
27 | dd($d->dialogDismiss);
28 | 
29 | 
30 | 


--------------------------------------------------------------------------------
/scriptlets/alert_dialog.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | use Android;
 7 | my $d = Android->new();
 8 | 
 9 | 
10 | dd($d->dialogCreateAlert("the title", "text"));
11 | dd($d->dialogSetPositiveButtonText("good"));
12 | dd($d->dialogSetNegativeButtonText("bad"));
13 | dd($d->dialogSetNeutralButtonText("ugly"));
14 | dd($d->dialogShow);
15 | 
16 | say("Still running");
17 | 
18 | dd($d->dialogGetResponse);
19 | 
20 | # This call waits for someone to press a button
21 | # the result is a hash with one pair. The key is "which".
22 | # The value is one of the following:
23 | # "neutral", "negative", "positive"
24 | 
25 | 


--------------------------------------------------------------------------------
/scriptlets/ringer_silent_mode.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | use Android;
 7 | my $d = Android->new();
 8 | 
 9 | 
10 | dd($d->checkRingerSilentMode); # result is a JSON::PP::Boolean object that stringifies to "true" or "false"
11 | say($d->checkRingerSilentMode->{result});
12 | 
13 | dd($d->toggleRingerSilentMode(1));
14 | say($d->checkRingerSilentMode->{result});                   # true
15 | say($d->checkRingerSilentMode->{result} ? 'ON' : 'OFF');    # ON
16 | 
17 | dd($d->toggleRingerSilentMode(0));
18 | say($d->checkRingerSilentMode->{result});                   # false
19 | say($d->checkRingerSilentMode->{result} ? 'ON' : 'OFF');    # OFF
20 | 
21 | 


--------------------------------------------------------------------------------
/README:
--------------------------------------------------------------------------------
 1 | This is a collection of Perl scripts that run on Android using ASE.
 2 | 
 3 | You can install an Android emulator using instructions from the Android
 4 | developers website and then install ASE (Android Scripting Environment).
 5 | Once you have it, you can install a Perl interpreter.
 6 | 
 7 | Hopefully these scripts will show an example of how to develop on Android with
 8 | Perl.
 9 | 
10 | Directory structure:
11 | bugs:       scripts that cover certain bugs
12 | examples:   actual examples of programs which should be integrated with ASE
13 | modules:    modules we want to (or have) integrated into ASE
14 | scriptlets: small little scripts that haven't materialized or stabilized
15 | Android.pm: the main Android module
16 | test.pl:    our testing suite
17 | README:     this file
18 | 


--------------------------------------------------------------------------------
/bugs/hires/hires_on_horizontal_progress.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | use Android;
 5 | use Time::HiRes 'sleep';
 6 | 
 7 | my $droid = Android->new();
 8 | 
 9 | eval {
10 |     local $SIG{'ALRM'} = sub { die "alarm\n" };
11 |     alarm 10;
12 |     print 'Sleep test... ';
13 | 
14 |     my $title   = 'Time::HiRes on horizontal';
15 |     my $message = 'This tests whether Time::HiRes works with this progress bar';
16 |     $droid->dialogCreateHorizontalProgress( $title, $message, 10 );
17 |     $droid->dialogShow();
18 |     for my $x ( 0 .. 50 ) {
19 |       sleep 0.1;
20 |       $droid->dialogSetCurrentProgress($x);
21 |     }
22 | 
23 |     $droid->dialogDismiss();
24 | 
25 |     alarm 0;
26 | };
27 | 
28 | 
29 | if ($@) {
30 |     if ( $@ eq "alarm\n" ) {
31 |         print "FAIL\n";
32 |     }
33 | } else {
34 |     print "PASS\n";
35 | }
36 | 


--------------------------------------------------------------------------------
/scriptlets/get.pl:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | 
 4 | require "/sdcard/ase/scripts/MyTools.pl";
 5 | 
 6 | use IO::Socket;
 7 | 
 8 | use Android;
 9 | my $d = Android->new();
10 | 
11 | 
12 | my $site  = 'http://perl.org/';
13 | 
14 | dd($d->getInput("URL", "Default: $site"));
15 | say(get($site));
16 | 
17 | 
18 | sub get {
19 | 	my ($url) = @_;
20 | 
21 | 	my $host = $url;
22 | 	$host =~ s{http://}{};
23 | 	$host =~ s{/.*}{};
24 | 	#print "$host\n";
25 | 	
26 | 	my $port = 80;
27 | 	my $CRLF = "\015\012";
28 | 	my $SIZE = 100;
29 | 	my $data = '';
30 | 	
31 | 	my $socket = IO::Socket::INET->new(
32 | 	   PeerAddr => $host,
33 | 	   PeerPort => $port,
34 | 	   Proto    => 'tcp',
35 | 	) or die $!;
36 | 	
37 | 	
38 | 	$socket->send("GET $url$CRLF") or die $!;
39 | 	#print "sent\n";
40 | 	
41 | 	while ($socket->read($data, $SIZE, length($data)) == $SIZE) {
42 | 	}
43 | 
44 | 	return $data;
45 | }
46 | 
47 | 


--------------------------------------------------------------------------------
/bugs/lastlocation_horizontal.pl:
--------------------------------------------------------------------------------
 1 | # this script shows how getLastKnownLocation disables the
 2 | # horizontal progress bar.
 3 | use strict;
 4 | use warnings;
 5 | 
 6 | use Android;
 7 | 
 8 | my $droid = Android->new();
 9 | $droid->getLastKnownLocation();
10 | 
11 | eval {
12 |     local $SIG{'ALRM'} = sub { die "alarm\n" };
13 |     alarm 12;
14 |     print 'Sleep test... ';
15 | 
16 |     my $title   = 'Horizontal';
17 |     my $message = 'This tests shows a bug with this progress bar';
18 |     $droid->dialogCreateHorizontalProgress( $title, $message, 10 );
19 |     $droid->dialogShow();
20 |     for my $x ( 0 .. 10 ) {
21 |       sleep 1;
22 |       $droid->dialogSetCurrentProgress($x);
23 |     }
24 | 
25 |     $droid->dialogDismiss();
26 | 
27 |     alarm 0;
28 | };
29 | 
30 | 
31 | if ($@) {
32 |     if ( $@ eq "alarm\n" ) {
33 |         print "FAIL\n";
34 |     }
35 | } else {
36 |     print "PASS\n";
37 | }
38 | 


--------------------------------------------------------------------------------
/examples/del_messages.pl:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | use strict; use warnings;
 3 | 
 4 | #######################################################################
 5 | # LICENSE AND COPYRIGHT
 6 | # --------------------- 
 7 | #
 8 | # Copyright (c) 2010 Rohan Almeida <rohan@almeida.in>
 9 | # All rights reserved.
10 | #######################################################################
11 | 
12 | use Android;
13 | use Carp;
14 | use Data::Dumper;
15 | 
16 | my $droid  = Android->new();
17 | my $unread_messages = $droid->smsGetMessages(1, 'inbox', ['body', '_id', 'thread_id',
18 |     'read']);
19 | croak "Unable to retreive SMS messages" if defined $unread_messages->{error};
20 | 
21 | #print Dumper $droid->smsGetAttributes();
22 | 
23 | my @unread_msgs = @{ $unread_messages->{result} };
24 | my %unread_map;
25 | for (my $i = 0; $i < scalar @unread_msgs; $i++) {
26 |     $unread_map{$i} = $unread_msgs[$i]->{_id};
27 | }
28 | #die Dumper \%unread_map;
29 | 
30 | $droid->dialogCreateAlert('Unread Messages');
31 | $droid->dialogSetPositiveButtonText('Delete');
32 | $droid->dialogSetNegativeButtonText('Cancel');
33 | $droid->dialogSetMultiChoiceItems( [ map { $_->{body} } @unread_msgs ] );
34 | $droid->dialogShow();
35 | 
36 | if ($droid->dialogGetResponse()->{result}{which} eq 'positive') {
37 |     my %sel_ids
38 |         = map { $_ => 1 } @{ $droid->dialogGetSelectedItems()->{result} };
39 |     #die Dumper \%sel_ids;
40 | 
41 |     for (keys %sel_ids) {
42 |         #my $msg = $droid->smsGetMessageById($unread_map{$_}, ['body', '_id', 'thread_id',
43 |             #'read', 'status', 'subject']);
44 |         my $val = $droid->smsDeleteMessage($unread_map{$_});
45 |         if ($val->{result}) {
46 |             print "Message with ID $_ deleted.\n";
47 |         }
48 |     }
49 | }
50 | 
51 | 


--------------------------------------------------------------------------------
/COMPILING:
--------------------------------------------------------------------------------
 1 | How to compile perl (the interpreter) for ASE/Android:
 2 | ======================================================
 3 | 
 4 | Requirements:
 5 | -------------
 6 | - ASE sources - includes the Perl interpreter (A.K.A., perl)
 7 | - Android sources
 8 | - Java 5 (to compile Android)
 9 | 
10 | The ASE sources can be fetched from the ASE website.
11 | The Android sources can be fetched from the Google Android website.
12 | Java 5 can be fetched from Sun's Java website.
13 | (check under "old versions of Java")
14 | 
15 | General instructions:
16 | ---------------------
17 | 
18 | 
19 | Ubuntu-specific instructions:
20 | -----------------------------
21 | For Ubuntu: you can go to a mirror and download specific packages and deps:
22 | example mirror: http://mt.archive.ubuntu.com/ubuntu/pool/multiverse/s/sun-java5/
23 | 
24 | Packages:
25 | - sun-java5-jdk_1.5.0-22-0ubuntu0.8.04_i386.deb
26 | - sun-java5-jre_1.5.0-22-0ubuntu0.8.04_all.deb
27 | - sun-java5-bin_1.5.0-22-0ubuntu0.8.04_i386.deb
28 | - sun-java5-demo_1.5.0-22-0ubuntu0.8.04_i386.deb
29 | 
30 | You'll need:
31 | - unixodbc{,-{bin,dev}}
32 | - java-common
33 | 
34 | Go in the Android source folder and run "make"
35 | 
36 | *********************************************************************************
37 | Go in the Android source folder and run "make"
38 | Download the source of Android from http://source.android.com/download and build
39 | it using "make".
40 | 
41 | As I understand that will get you the right arm-eabi toolchain. The binary agcc
42 | comes from there.
43 | 
44 | the frontend wrapper agcc is in the android-scripting repository in
45 | tools/agcc/agcc.
46 | 
47 | In order to build perl in the android-scripting repository:
48 |     cd perl/src/Cross/
49 |     sh build-arm-android-sh
50 | 
51 | and to package the result:
52 |     sh package-android-sh
53 | 
54 | I know I got a failure as my sh was linked to dash.
55 | Running bash worked better but I have not managed to setup the agcc thing.
56 | 
57 | *********************************************************************************
58 | 


--------------------------------------------------------------------------------
/examples/plack.pl:
--------------------------------------------------------------------------------
 1 | # Running Plack on Android using ASE
 2 | # Originally written by Stevan Little (minor cleanups by Sawyer X)
 3 | # Copied here with explicit permission
 4 | # (thank you Stevan :)
 5 | 
 6 | # Stevan also notes that he had to make the following modules available
 7 | # in order to make this work:
 8 | # - Devel-StackTrace-1.22.tar.gz
 9 | # - Devel-StackTrace-AsHTML-0.09.tar.gz
10 | # - FileHandle.pm
11 | # - HTTP-Body-1.07.tar.gz
12 | # - HTTP-Server-Simple-0.42.tar.gz
13 | # - Hash-MultiValue-0.08.tar.gz
14 | # - PathTools-3.31.tar.gz
15 | # - PerlIO.pm
16 | # - Plack-0.9929.tar.gz
17 | # - Pod-Parser-1.38.tar.gz
18 | # - Time-Local-1.1901.tar.gz
19 | # - Try-Tiny-0.04.tar.gz
20 | # - URI-1.54.tar.gz
21 | # - integer.pm
22 | # - libwww-perl-5.834.tar.gz
23 | # - parent-0.223.tar.gz
24 | 
25 | use strict;
26 | use warnings;
27 | 
28 | BEGIN {
29 |     my @modules = qw/
30 |         Devel::StackTrace Devel::StackTrace::AsHTML FileHandle HTTP::Body
31 |         HTTP::Server::Simple Hash::MultiValue PathTools PerlIO Plack Pod::Parser
32 |         Time::Local Try::Tiny URI integer LWP parent
33 |     /;
34 | 
35 |     foreach my $module (@modules) {
36 |         eval "use $module";
37 |         $@ and die "You do not have $module installed, sorry.\n"; }
38 |     }
39 | }
40 | 
41 | use Android;
42 | use Plack::Runner;
43 | use Plack::Request;
44 | 
45 | my $droid  = Android->new();
46 | my $runner = Plack::Runner->new();
47 | 
48 | $runner->parse_options( qw(
49 |     --server HTTP::Server::PSGI
50 |     --port   8888
51 | ) );
52 | 
53 | $runner->run( sub {
54 |     my $env = shift;
55 |     my $req = Plack::Request->new( $env );
56 | 
57 |     if ( my $phone_number = $req->param('phone_number') ) {
58 |         $a->callNumber( $phone_number );
59 | 
60 |         return [
61 |             200,
62 |             [ 'Content-Type' => 'text/html' ],
63 |             [ qq(
64 |                 <html>
65 |                     <head>
66 |                         <title>Plack On Droid</title>
67 |                     </head>
68 |                     <body>
69 |                         <p>Calling $phone_number ...</p>
70 |                     </body>
71 |                 </html>
72 |             ) ],
73 |         ];
74 |     } else {
75 |         return [
76 |             200,
77 |             [ 'Content-Type' => 'text/html' ],
78 |             [ q(
79 |                 <html>
80 |                     <head>
81 |                         <title>Plack On Droid</title>
82 |                     </head>
83 |                     <body>
84 |                         <form>
85 |                             Enter a phone number to call<br/>
86 |                             <input type="text" name="phone_number" />
87 |                             <input type="submit" value="Go" />
88 |                         </form>
89 |                     </body>
90 |                 </html>
91 |             ) ],
92 |         ];
93 |     }
94 | } );
95 | 
96 | 


--------------------------------------------------------------------------------
/examples/sms_search.pl:
--------------------------------------------------------------------------------
 1 | #!/data/data/com.google.ase/perl/perl
 2 | #
 3 | # Copyright 2010 Alex Elder (http://www.alexelder.co.uk)
 4 | #
 5 | # Licensed under the Apache License, Version 2.0 (the "License"); you may not
 6 | # use this file except in compliance with the License.  You may obtain a copy of
 7 | # the License at
 8 | #
 9 | # http://www.apache.org/licenses/LICENSE-2.0
10 | #
11 | # Unless required by applicable law or agreed to in writing, software
12 | # distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
13 | # WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.  See the
14 | # License for the specific language governing permissions and limitations under
15 | # the License.
16 | #
17 | # A simplistic example, demonstrating how to implement a simple search tool
18 | # using ASE and Perl.
19 | #
20 | use strict; 
21 | use warnings;
22 | 
23 | use Android;
24 | use Carp;
25 | use Data::Dumper;
26 | 
27 | use constant {
28 |     INPUT_TITLE   => 'Search String',
29 |     INPUT_MESSAGE => 'Enter a search string or Perl regex:',
30 | };
31 | 
32 | my $droid    = Android->new();
33 | my $messages = $droid->smsGetMessages(0, 'inbox', ['body', 'thread_id']);
34 | 
35 | croak "Unable to retreive SMS messages" if defined $messages->{error};
36 | 
37 | my $search_string = $droid->getInput(INPUT_TITLE, INPUT_MESSAGE);
38 | 
39 | if ( defined $search_string->{error} ) {
40 | 
41 |     $droid->makeToast('No search string entered; try again...');
42 |     $search_string = $droid->getInput(INPUT_TITLE, INPUT_MESSAGE);
43 | 
44 |     exit if defined $search_string->{error};
45 | }
46 | 
47 | $search_string = qr/$search_string->{result}/;
48 | 
49 | my @matches;
50 | 
51 | foreach my $message ( @{ $messages->{result} } ) {
52 | 
53 |     if ( $message->{body} =~ $search_string ) {
54 | 
55 |         push @matches, $message;
56 |     }
57 | }
58 | 
59 | if ( ! @matches ) {
60 | 
61 |     $droid->makeToast("No matches found for '$search_string'");
62 |     exit;
63 | }
64 | else {
65 | 
66 |     $droid->makeToast("Found " . scalar @matches . " matches!");
67 | }
68 | 
69 | # Extract just the body part from each message and display it on the UI using
70 | # the index within @matches as the return ID from the UI component:
71 | $droid->dialogCreateAlert('Search Results');
72 | $droid->dialogSetItems([ map { $_->{body} } @matches ] );
73 | $droid->dialogShow();
74 | 
75 | my $selected_search_result = $droid->dialogGetResponse();
76 | 
77 | if ( defined $selected_search_result->{error} ) {
78 | 
79 |     $droid->makeToast('Invalid choice; exiting');
80 |     $droid->exit();
81 | }
82 | else {
83 |     $selected_search_result = $selected_search_result->{result}->{item};
84 | }
85 | 
86 | my $sms_thread_id = $matches[$selected_search_result]->{thread_id};
87 | 
88 | # FIXME: This needs addressing. Currently, the below URI will navigate to the
89 | # correct message thread, however it will not navigate to the correct message
90 | # *within* the given thread. I'm not too sure how to do this, and it doesn't
91 | # seem to be too well documented.
92 | $droid->startActivity('android.intent.action.VIEW', "sms://view/conversations/$sms_thread_id");
93 | 
94 | $droid->exit();
95 | 


--------------------------------------------------------------------------------
/test.pl:
--------------------------------------------------------------------------------
  1 | # Author: Sawyer X
  2 | # Email:  xsawyerx@cpan.org or xsawyerx@gmail.com
  3 | 
  4 | use strict;
  5 | use warnings;
  6 | 
  7 | use Android;
  8 | use Try::Tiny;
  9 | use Test::More tests => 24;
 10 | 
 11 | local $|       = 1;
 12 | our   $VERSION = '0.03';
 13 | my    $droid   = Android->new();
 14 | my    $count   = 0;
 15 | my    @failed  = ();
 16 | 
 17 | sub event_loop {
 18 |   for my $i ( 1 .. 10 ) {
 19 |     my $e = $droid->receiveEvent();
 20 |     exists $e->{'result'} and return 1;
 21 |     sleep 2;
 22 |   }
 23 | 
 24 |   return;
 25 | }
 26 | 
 27 | # tests should return TRUE for pass, FALSE for fail
 28 | my @tests = (
 29 |   [ clipboard => sub {
 30 |     my $previous = $droid->getClipboard()->{'result'};
 31 |     my $msg      = 'Hello, Perl!';
 32 |     $droid->setClipboard($msg);
 33 |     my $echo     = $droid->getClipboard()->{'result'};
 34 |     $droid->setClipboard($previous);
 35 | 
 36 |     return $echo eq $msg;
 37 |   } ],
 38 | 
 39 |   # we don't have gdata, we can try Net::Google or others instead
 40 |   # but since they aren't bundled, this test would be pointless
 41 |   # TODO (sawyer): this test :)
 42 |   [ gdata => sub {} ],
 43 | 
 44 |   [ gps => sub {
 45 |     $droid->startLocating();
 46 |     try     { return event_loop()    }
 47 |     finally { $droid->stopLocating() };
 48 |   } ],
 49 | 
 50 |   [ sensors => sub {
 51 |     $droid->startSensing();
 52 |     try     { return event_loop()   }
 53 |     finally { $droid->stopSensing() };
 54 |   } ],
 55 | 
 56 |   [ speak => sub {
 57 |     my $result = $droid->speak('Hello, Perl!');
 58 |     return not defined $result->{'error'};
 59 |   } ],
 60 | 
 61 |   [ phone_state => sub {
 62 |     $droid->startTrackingPhoneState();
 63 |     try     { return event_loop()              }
 64 |     finally { $droid->stopTrackingPhoneState() };
 65 |   } ],
 66 | 
 67 |   [ ringer_silent => sub {
 68 |     my $result1 = $droid->toggleRingerSilentMode();
 69 |     my $result2 = $droid->toggleRingerSilentMode();
 70 |     return ( not defined $result1->{'error'} ) and
 71 |            ( not defined $result2->{'error'} );
 72 |   } ],
 73 | 
 74 |   [ ringer_volume => sub {
 75 |     my $get_result = $droid->getRingerVolume();
 76 |     $get_result->{'error'} and return;
 77 | 
 78 |     $droid->setRingerVolume(0);
 79 |     my $set_result = $droid->setRingerVolume( $get_result->{'result'} );
 80 |     $set_result->{'error'} and return;
 81 | 
 82 |     return 1;
 83 |   } ],
 84 | 
 85 |   [ get_last_known_location => sub {
 86 |     my $result = $droid->getLastKnownLocation();
 87 |     return not defined $result->{'error'};
 88 |   } ],
 89 | 
 90 |   [ geocode => sub {
 91 |     my $result = $droid->geocode( 0.0, 0.0, 1 );
 92 |     return not defined $result->{'error'};
 93 |   } ],
 94 | 
 95 |   [ wifi => sub {
 96 |     my $result1 = $droid->toggleWifiState();
 97 |     my $result2 = $droid->toggleWifiState();
 98 |     return ( not defined $result1->{'error'} ) and
 99 |            ( not defined $result2->{'error'} );
100 |   } ],
101 | 
102 |   [ make_toast => sub {
103 |     my $result = $droid->makeToast('Hello, Perl!');
104 |     return not defined $result->{'error'};
105 |   } ],
106 | 
107 |   [ vibrate => sub {
108 |     my $result = $droid->vibrate();
109 |     return not defined $result->{'error'};
110 |   } ],
111 | 
112 |   [ notify => sub {
113 |     my $result = $droid->notify('Hello, Perl!');
114 |     return not defined $result->{'error'};
115 |   } ],
116 | 
117 |   [ get_running_packages => sub {
118 |     my $result = $droid->getRunningPackages();
119 |     return not defined $result->{'error'};
120 |   } ],
121 | 
122 |   [ alert_dialog => sub {
123 |     my $title   = 'User Interface';
124 |     my $message = 'Welcome to the ASE integration test.';
125 |     $droid->dialogCreateAlert( $title, $message );
126 |     $droid->dialogSetPositiveButtonText('Continue');
127 |     $droid->dialogShow();
128 |     my $response = $droid->dialogGetResponse()->{'result'};
129 |     return $response->{'which'} eq 'positive';
130 |   } ],
131 | 
132 |   [ alert_dialog_with_buttons => sub {
133 |     my $title   = 'Alert';
134 |     my $message = 'This alert box has 3 buttons and ' .
135 |                   'will wait for you to press one';
136 |     $droid->dialogCreateAlert( $title, $message );
137 |     $droid->dialogSetPositiveButtonText('Yes');
138 |     $droid->dialogSetNegativeButtonText('No');
139 |     $droid->dialogSetNeutralButtonText('Cancel');
140 |     $droid->dialogShow();
141 |     my $response = $droid->dialogGetResponse->{'result'};
142 |     my $which    = $response->{'which'};
143 |     return grep /^$which$/, 'positive', 'negative', 'neutral';
144 |   } ],
145 | 
146 |   [ spinner_progress => sub {
147 |     my $title   = 'Spinner';
148 |     my $message = 'This is simple spinner progress.';
149 |     $droid->dialogCreateSpinnerProgress( $title, $message );
150 |     $droid->dialogShow();
151 |     sleep 2;
152 |     $droid->dialogDismiss();
153 |     return 1;
154 |   } ],
155 | 
156 |   [ horizontal_progress => sub {
157 |     my $title   = 'Horizontal';
158 |     my $message = 'This is simple horizontal progress.';
159 |     $droid->dialogCreateHorizontalProgress( $title, $message, 50 );
160 |     $droid->dialogShow();
161 |     for my $x ( 0 .. 50 ) {
162 |       # kinky way of sleeping 0.1 instead of using Time::HiRes
163 |       select undef, undef, undef, 0.1;
164 |       $droid->dialogSetCurrentProgress($x);
165 |     }
166 |     $droid->dialogDismiss();
167 |     return 1;
168 |   } ],
169 | 
170 |   [ alert_dialog_with_list => sub {
171 |     my $title = 'Alert';
172 |     $droid->dialogCreateAlert($title);
173 |     $droid->dialogSetItems( [ qw/foo bar baz/ ] );
174 |     $droid->dialogShow();
175 |     my $response = $droid->dialogGetResponse()->{'result'};
176 |     return 1;
177 |   } ],
178 | 
179 |   [ alert_dialog_with_single_choice_list => sub {
180 |     my $title = 'Alert';
181 |     $droid->dialogCreateAlert($title);
182 |     $droid->dialogSetSingleChoiceItems( [ qw/foo bar baz/ ] );
183 |     $droid->dialogSetPositiveButtonText('Yay!');
184 |     $droid->dialogShow();
185 |     my $response = $droid->dialogGetResponse()->{'result'};
186 |     return 1;
187 |   } ],
188 | 
189 |   [ alert_dialog_with_multi_choice_list => sub {
190 |     my $title = 'Alert';
191 |     $droid->dialogCreateAlert($title);
192 |     $droid->dialogSetMultiChoiceItems( [ qw/foo bar baz/ ], [] );
193 |     $droid->dialogSetPositiveButtonText('Yay!');
194 |     $droid->dialogShow();
195 |     my $response = $droid->dialogGetResponse()->{'result'};
196 |     return 1;
197 |   } ],
198 | 
199 |   [ api_pick_contact => sub {
200 |       my $contact = $droid->pickContact();
201 |       return $contact->{'result'};
202 |   } ],
203 | 
204 |   [ api_pick_phone => sub {
205 |       my $phone = $droid->pickPhone();
206 |       return $phone->{'result'};
207 |   } ],
208 | 
209 | );
210 | 
211 | foreach my $test (@tests) {
212 |   my ( $name, $callback ) = @{$test};
213 |   $count++;
214 | 
215 |   if ( $callback->() ) {
216 |     print 'ok';
217 |   } else {
218 |     print 'not ok';
219 |     push @failed, $name;
220 |   }
221 | 
222 |   print " $count - $name\n";
223 | }
224 | 
225 | print "1..$count\n";
226 | 
227 | print map { "# failed test '$_'\n" } @failed;
228 | 
229 | 


--------------------------------------------------------------------------------
/examples/gps_send_message.pl:
--------------------------------------------------------------------------------
  1 | #!/data/data/com.google.ase/perl/perl
  2 | #
  3 | # Copyright 2010 Alex Elder (http://www.alexelder.co.uk)
  4 | #
  5 | # Licensed under the Apache License, Version 2.0 (the "License"); you may not
  6 | # use this file except in compliance with the License.  You may obtain a copy of
  7 | # the License at
  8 | #
  9 | # http://www.apache.org/licenses/LICENSE-2.0
 10 | #
 11 | # Unless required by applicable law or agreed to in writing, software
 12 | # distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
 13 | # WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.  See the
 14 | # License for the specific language governing permissions and limitations under
 15 | # the License.
 16 | #
 17 | # A simple Perl script designed to run under the Android Scripting Environment:
 18 | # http://code.google.com/p/android-scripting. Designed to dispatch a text
 19 | # message when the phone's position matches the position entered by the user.
 20 | # For best results, start this program as a service.
 21 | #
 22 | # Text messages support 'tags' which are substituted for values before the
 23 | # message is sent. Currently supported tags are: 
 24 | #
 25 | #   admin_area 
 26 | #   country_code
 27 | #   country_name 
 28 | #   feature_name 
 29 | #   locality
 30 | #   postal_code
 31 | #   thoroughfare
 32 | #   sub_admin_area
 33 | #   map_link
 34 | #
 35 | # All tags must start and end with a '%' (percentage) sign. For example,
 36 | # if you would like to send a message as soon as you entered Cheshire to a
 37 | # chosen contact, and within that message you'd like to embed your current
 38 | # county and a Google Maps link, you could enter something similar to:
 39 | #
 40 | #   "Hi, I'm just entering %admin_area% now; link: %map_link%. See you soon!" 
 41 | #
 42 | # The tags in the above example would be substituted for their actual values:
 43 | # 
 44 | #   "Hi, I'm just entering Cheshire now; link:
 45 | #   http://maps.google.com/maps?q=53.800651,-4.064941. See you soon!"
 46 | #
 47 | use strict; 
 48 | use warnings;
 49 | 
 50 | use Android;
 51 | use Carp;
 52 | 
 53 | use constant {
 54 |     LOOP_DELAY    => 180, # seconds to sleep between checking GPS position
 55 |     MAX_ATTEMPTS  => 250, # number of match-loop iterations before giving up
 56 |     SPEAK_ON_SEND => 1,   # speak using TTS when the message is sent
 57 |     MAP_LINK      => 'http://maps.google.com/maps?q=%s,%s', # map link (message 'tag')
 58 | };
 59 | 
 60 | my $droid = Android->new();
 61 | 
 62 | $droid->makeToast('Select a contact');
 63 | 
 64 | my $contact;
 65 | 
 66 | # Select a contact
 67 | $contact = $droid->pickPhone();
 68 | 
 69 | if ( ! defined $contact->{result} ) {
 70 | 
 71 |     $droid->makeToast('Please select a contact');
 72 |     $contact = $droid->pickPhone();
 73 | 
 74 |     exit if defined $contact->{error};
 75 | }
 76 | 
 77 | $contact = $contact->{result};
 78 | 
 79 | # Enter a message for the chosen contact
 80 | my $message_to_contact = $droid->getInput('Message', 'Message to selected contact');
 81 | 
 82 | if ( defined $message_to_contact->{error} || ! defined $message_to_contact->{result} ) {
 83 | 
 84 |     $droid->makeToast('No message entered. Please enter a message.');
 85 |     $message_to_contact = $droid->getInput('Message', 'Message to be sent to contact upon arrival');
 86 | 
 87 |     exit if defined $message_to_contact->{error} || ! defined $message_to_contact->{result};
 88 | }
 89 | 
 90 | $message_to_contact = $message_to_contact->{result};
 91 | 
 92 | # Message authors can embed 'tags' that are substituted before a message is sent
 93 | # to the chosen contact. The tag start and end markers are '%' and '%'
 94 | # respectively.
 95 | my @gps_keys = qw/ 
 96 |     admin_area 
 97 |     country_code 
 98 |     country_name 
 99 |     feature_name 
100 |     locality
101 |     postal_code
102 |     thoroughfare
103 |     sub_admin_area
104 | /;
105 | 
106 | # Create a dialog and present it to the user. They need to select which area
107 | # they'd like their location matched against. This is a potential 'non-slick' as
108 | # it'd be much nicer to use a Maps instance and geocode a screen tap, rather
109 | # than asking for someone to enter text. However, seems the Map application
110 | # starts itself in a new task when launched, making is *very* hard to get the
111 | # return value. For more information, please read: http://bit.ly/a7krNU.
112 | 
113 | # Create a UI component and force the user to select a GPS zone to match on:
114 | $droid->dialogCreateAlert('Match location using...');
115 | $droid->dialogSetItems(\@gps_keys);
116 | $droid->dialogShow();
117 | 
118 | my $match_key = $droid->dialogGetResponse();
119 | 
120 | exit if ! defined $match_key->{result}->{item};
121 | 
122 | if ( $match_key->{result}->{item} >= 0 && $match_key->{result}->{item} <= scalar @gps_keys ) {
123 |     $match_key = $gps_keys[$match_key->{result}->{item}];
124 | }
125 | else {
126 |     # use the first element in the allowed tags list as the default matching method
127 |     $match_key = $gps_keys[0];
128 | }
129 | 
130 | # Add the 'map_link' here, rather than above because the map link isn't a GPS
131 | # result - however it is a valid substitution tag, used for inserting a Google
132 | # Maps URI.
133 | push @gps_keys, 'map_link';
134 | 
135 | # Enter destination
136 | my $destination = $droid->getInput('Destination', 'Please enter your destination');
137 | 
138 | if ( defined $destination->{error} || ! defined $destination->{result} ) {
139 | 
140 |     $droid->makeToast('No destination entered. Please enter a destination.');
141 |     $destination = $droid->getInput('Destination', 'Please enter your destination');
142 | 
143 |     exit if defined $destination->{error} || ! defined $destination->{result};
144 | }
145 | 
146 | $destination = $destination->{result};
147 | 
148 | # When using the selected text input, the input keyboard will often suggest a
149 | # word and add a space after the selected word, so remove any trailing whitespace
150 | # here for convenience.
151 | $destination =~ s/\s+$//;
152 | 
153 | # Keep a count of how many times the script's looped around while attempting to
154 | # find a match.
155 | my $attempts = 0;
156 | 
157 | my ($location, $longitude, $latitude, $geocode);
158 | 
159 | $droid->startLocating();
160 | 
161 | # give the GPS sensor a chance to wake up
162 | sleep 15;
163 | 
164 | CHECK_LOCATION:
165 | while ( $attempts++ <= MAX_ATTEMPTS ) {
166 | 
167 |     $location = $droid->readLocation() || $droid->getLastKnownLocation();
168 | 
169 |     if ( defined $location->{error} ) {
170 | 
171 |         print STDERR "location error: $location->{error}\n";
172 |         next CHECK_LOCATION;
173 |     }
174 | 
175 |     $longitude = $location->{result}->{network}->{longitude};
176 |     $latitude  = $location->{result}->{network}->{latitude};
177 | 
178 |     $geocode = $droid->geocode($latitude, $longitude);
179 | 
180 |     if ( defined $geocode->{error} ) {
181 | 
182 |         print STDERR "geocode error: $geocode->{error}\n";
183 |         next CHECK_LOCATION;
184 |     }
185 | 
186 |     foreach my $address ( @{ $geocode->{result} } ) {
187 | 
188 |         if ( $address->{$match_key} =~ /$destination/i ) {
189 | 
190 |             # add a maps link to the address hash
191 |             my $map_link = sprintf(MAP_LINK, $latitude, $longitude);
192 |             $address->{map_link} = $map_link;
193 | 
194 |             # replace special tags in the input messages
195 |             $message_to_contact =~ s/%*$_*%/$address->{$_}/g for @gps_keys;
196 | 
197 |             print "successfully matched $address->{$match_key} against $destination\n";
198 |             print "sending: '$message_to_contact' to contact $contact\n";
199 | 
200 |             $droid->smsSend($contact, $message_to_contact);
201 |             $droid->speak("Message sent to contact after $attempts attempts.") if SPEAK_ON_SEND == 1;
202 | 
203 |             last CHECK_LOCATION;
204 |         }
205 |     }
206 | 
207 |     sleep LOOP_DELAY;
208 | }
209 | 
210 | exit;
211 | 


--------------------------------------------------------------------------------
/Android.pm:
--------------------------------------------------------------------------------
  1 | # Copyright (C) 2009 Google Inc.
  2 | #
  3 | # Licensed under the Apache License, Version 2.0 (the "License"); you may not
  4 | # use this file except in compliance with the License. You may obtain a copy of
  5 | # the License at
  6 | #
  7 | # http://www.apache.org/licenses/LICENSE-2.0
  8 | #
  9 | # Unless required by applicable law or agreed to in writing, software
 10 | # distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
 11 | # WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
 12 | # License for the specific language governing permissions and limitations under
 13 | # the License.
 14 | 
 15 | #
 16 | # Author: Jarkko Hietaniemi <jhi@google.com>
 17 | #
 18 | 
 19 | package Android;
 20 | 
 21 | use strict;
 22 | 
 23 | use vars qw($VERSION $AUTOLOAD);
 24 | 
 25 | $VERSION = 0.001;
 26 | 
 27 | use IO::Socket;
 28 | use JSON;
 29 | use Getopt::Long;
 30 | use Data::Dumper;
 31 | 
 32 | my %Opt;
 33 | 
 34 | # You can specify the server port number to contact either via the
 35 | # $ENV{AP_PORT} (the default behaviour) or via --port=n (when debugging
 36 | # Android.pm and/or running in server mode, the default being client mode).
 37 | # Running a test server:
 38 | # perl -w Android.pm --port=4321 --trace --server
 39 | # Running a test client:
 40 | # perl -w Android.pm --port=4321 --trace --request Bar 1 2 foo 3.4
 41 | 
 42 | # This BEGIN parses options, if any.
 43 | BEGIN {
 44 |     %Opt = (port => $ENV{AP_PORT} ? $ENV{AP_PORT} : 4321);
 45 |     GetOptions('port=i' => \$Opt{port},
 46 |                'server' => \$Opt{server},
 47 |                'request' => \$Opt{request},
 48 |                'trace' => \$Opt{trace}) or
 49 |                  die "$0: Usage: $0 [--port=n] [--server] [--request method ...]\n";
 50 |     (defined $Opt{port} && $Opt{port} =~ /^\d+$/)
 51 |       or die "$0: AP_PORT '$Opt{port}' undefined or illegal\n";
 52 | }
 53 | 
 54 | # server() is run if --server is given to Android.pm.
 55 | sub server {
 56 |   # getprotobyname() is still a fatally unimplemented stub in Android 2.0.1.
 57 |   my $proto = eval { getprotobyname('tcp') } || 6;
 58 |   my $server = IO::Socket::INET->new(Proto     => 'tcp',
 59 |                                      LocalPort => $Opt{port},
 60 |                                      Listen    => SOMAXCONN,
 61 |                                      Reuse     => 1);
 62 |   die "$0: Cannot start server: $!\n" unless defined $server;
 63 |   if ($Opt{trace}) {
 64 |       show_trace(qq[$0: server: accepting in port $Opt{port}]);
 65 |   }
 66 |   while (defined(my $client = $server->accept())) {
 67 |       show_trace(qq[$0: server: client $client]) if $Opt{trace};
 68 |       $client->autoflush(1);
 69 |       my $json = readline($client);
 70 |       chomp($json);
 71 |       show_trace(qq[server: rcvd: "$json"]) if $Opt{trace};
 72 |       print $client $json, "\n";  # We just echo back what they said to us.
 73 |       show_trace(qq[server: sent: "$json"]) if $Opt{trace};
 74 |       close($client);
 75 |   }
 76 | }
 77 | 
 78 | sub new {
 79 |     my $class = shift;
 80 |     if (@_) {
 81 |         print STDERR "$0: client: new() expected no arguments, got @_\n";
 82 |     }
 83 |     my $fh = IO::Socket::INET->new(Proto    => 'tcp',
 84 |                                    PeerAddr => 'localhost',
 85 |                                    PeerPort => $Opt{port})
 86 |         or die "$0: Cannot connect to server port $Opt{port} on localhost\n";
 87 |     $fh->autoflush(1);
 88 |     if ($Opt{trace}) {
 89 |         show_trace(qq[Android: server in port $Opt{port}]);
 90 |     }
 91 |     bless {
 92 |         conn => $fh,
 93 |         id   => 0,
 94 |     }, $class;
 95 | }
 96 | 
 97 | # One can use this to set the proxy object to display what's being
 98 | # sent down and up the wire (as JSON), or query the state of tracing.
 99 | # If tracing is on, the client library will also dump the Perl result
100 | # that was decoded from JSON.
101 | sub trace {
102 |     if (@_ == 2) {
103 |         $_[0]->{trace} = $_[1];
104 |     } else {
105 |         return $_[0]->{trace};
106 |     }
107 | }
108 | 
109 | # Utility function for showing traces.
110 | sub show_trace {
111 |   print STDERR "<<@_>>\n";
112 | }
113 | 
114 | # The connection is implicitly closed when the proxy object goes out
115 | # of scope, but one can use the close() method to explicitly terminate
116 | # the connection.  This is also used internally by the do_rpc() in
117 | # case the server end looks to have gone away.  The _close() closes
118 | # the connection quietly, close() closes the connection noisily.
119 | sub _close {
120 |     if (defined $_[0]->{conn}) {
121 |         close($_[0]->{conn});
122 |         undef $_[0]->{conn};
123 |     }
124 | }
125 | sub close {
126 |     my $self = shift;
127 |     $self->_close();
128 |     print STDERR "$0: client: connection closed\n";
129 | }
130 | 
131 | # Given a method and parameters, call the server with JSON,
132 | # and return the parsed the response JSON.  If the server side
133 | # looks to be dead, close the connection and return undef.
134 | sub do_rpc {
135 |     my $self = shift;
136 |     if ($self->trace) {
137 |         show_trace(qq[do_rpc: $self: @_]);
138 |     }
139 |     my $method = pop;
140 |     my $request = to_json({ id => $self->{id},
141 |                             method => $method,
142 |                             params => [ @_ ] });
143 |     if (defined $self->{conn}) {
144 |         print { $self->{conn} } $request, "\n";
145 |         if ($self->trace) {
146 |             show_trace(qq[client: sent: "$request"]);
147 |         }
148 |         $self->{id}++;
149 |         my $response = readline($self->{conn});
150 |         chomp $response;
151 |         if ($self->trace) {
152 |             show_trace(qq[client: rcvd: "$response"]);
153 |         }
154 |         if (defined $response && length $response) {
155 |             my $result = from_json($response);
156 |             my $success = 0;
157 |             my $error;
158 |             if (defined $result) {
159 |                 if (ref $result eq 'HASH') {
160 |                     if (defined $result->{error}) {
161 |                         $error = to_json( { error => $result->{error} } );
162 |                     } else {
163 |                         $success = 1;
164 |                     }
165 |                 } else {
166 |                     $error = "illegal JSON reply: $result";
167 |                 }
168 |             }
169 |             unless ($success || defined $error) {
170 |                 $error = "unknown JSON error";
171 |             }
172 |             if (defined $error) {
173 |                 printf STDERR "$0: client: error: %s\n", $error;
174 |             }
175 |             if ($Opt{trace}) {
176 |                 print STDERR Data::Dumper->Dump([$result], [qw(result)]);
177 |             }
178 |             return $result;
179 |         }
180 |     }
181 |     $self->close;
182 |     return;
183 | }
184 | 
185 | # Return stubs that call do_rpc() with the method name smuggled in.
186 | sub rpc_maker {
187 |     if ($Opt{trace}) {
188 |         show_trace(qq[rpc_maker: @_]);
189 |     }
190 |     my $method = shift;
191 |     sub {
192 |         push @_, $method;
193 |         goto &do_rpc;  # Knock the stub out of the call stack.
194 |     }
195 | }
196 | 
197 | # AUTOLOAD installs RPC proxies for all unknown methods.
198 | sub AUTOLOAD {
199 |     if ($Opt{trace}) {
200 |         show_trace(qq[AUTOLOAD=$AUTOLOAD, @_]);
201 |     }
202 |     my ($method) = ($AUTOLOAD =~ /::(\w+)$/);
203 |     return if $method eq 'DESTROY';
204 |     my $rpc = rpc_maker($method);
205 |     {
206 |         # Install the RPC proxy method, we will not came here
207 |         # any more for the same method name.
208 |         no strict 'refs';
209 |         *$method = $rpc;
210 |     }
211 |     goto &$rpc;  # Call the RPC now.
212 | }
213 | 
214 | sub DESTROY {
215 |     $_[0]->_close();
216 | }
217 | 
218 | # This BEGIN block either invokes server() or sends a client request,
219 | # or does nothing (the case of using Android.pm as a client library).
220 | sub BEGIN {
221 |     if (defined $Opt{server}) {
222 |         &server;
223 |     } elsif (defined $Opt{request}) {
224 |         my $android = Android->new();
225 |         $android->trace(1) if $Opt{trace};
226 |         my $method = shift @ARGV;
227 |         $android->$method(@ARGV);
228 |         exit(0);
229 |     }
230 | }
231 | 
232 | 1;
233 | 


--------------------------------------------------------------------------------
/modules/Try/Tiny.pm:
--------------------------------------------------------------------------------
  1 | package Try::Tiny;
  2 | 
  3 | use strict;
  4 | #use warnings;
  5 | 
  6 | use vars qw(@EXPORT @EXPORT_OK $VERSION @ISA);
  7 | 
  8 | BEGIN {
  9 | 	require Exporter;
 10 | 	@ISA = qw(Exporter);
 11 | }
 12 | 
 13 | $VERSION = "0.04";
 14 | 
 15 | $VERSION = eval $VERSION;
 16 | 
 17 | @EXPORT = @EXPORT_OK = qw(try catch finally);
 18 | 
 19 | $Carp::Internal{+__PACKAGE__}++;
 20 | 
 21 | # Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
 22 | # Keeping it at $$ means you only ever get 1 sub because we need to eval in a list
 23 | # context & not a scalar one
 24 | 
 25 | sub try (&;@) {
 26 | 	my ( $try, @code_refs ) = @_;
 27 | 
 28 | 	# we need to save this here, the eval block will be in scalar context due
 29 | 	# to $failed
 30 | 	my $wantarray = wantarray;
 31 | 
 32 | 	my ( $catch, $finally );
 33 | 
 34 | 	# find labeled blocks in the argument list.
 35 | 	# catch and finally tag the blocks by blessing a scalar reference to them.
 36 | 	foreach my $code_ref (@code_refs) {
 37 | 		next unless $code_ref;
 38 | 
 39 | 		my $ref = ref($code_ref);
 40 | 
 41 | 		if ( $ref eq 'Try::Tiny::Catch' ) {
 42 | 			$catch = ${$code_ref};
 43 | 		} elsif ( $ref eq 'Try::Tiny::Finally' ) {
 44 | 			$finally = ${$code_ref};
 45 | 		} else {
 46 | 			use Carp;
 47 | 			confess("Unknown code ref type given '${ref}'. Check your usage & try again");
 48 | 		}
 49 | 	}
 50 | 
 51 | 	# save the value of $@ so we can set $@ back to it in the beginning of the eval
 52 | 	my $prev_error = $@;
 53 | 
 54 | 	my ( @ret, $error, $failed );
 55 | 
 56 | 	# FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
 57 | 	# not perfect, but we could provide a list of additional errors for
 58 | 	# $catch->();
 59 | 
 60 | 	{
 61 | 		# localize $@ to prevent clobbering of previous value by a successful
 62 | 		# eval.
 63 | 		local $@;
 64 | 
 65 | 		# failed will be true if the eval dies, because 1 will not be returned
 66 | 		# from the eval body
 67 | 		$failed = not eval {
 68 | 			$@ = $prev_error;
 69 | 
 70 | 			# evaluate the try block in the correct context
 71 | 			if ( $wantarray ) {
 72 | 				@ret = $try->();
 73 | 			} elsif ( defined $wantarray ) {
 74 | 				$ret[0] = $try->();
 75 | 			} else {
 76 | 				$try->();
 77 | 			};
 78 | 
 79 | 			return 1; # properly set $fail to false
 80 | 		};
 81 | 
 82 | 		# copy $@ to $error; when we leave this scope, local $@ will revert $@
 83 | 		# back to its previous value
 84 | 		$error = $@;
 85 | 	}
 86 | 
 87 | 	# set up a scope guard to invoke the finally block at the end
 88 | 	my $guard = $finally && bless \$finally, "Try::Tiny::ScopeGuard";
 89 | 
 90 | 	# at this point $failed contains a true value if the eval died, even if some
 91 | 	# destructor overwrote $@ as the eval was unwinding.
 92 | 	if ( $failed ) {
 93 | 		# if we got an error, invoke the catch block.
 94 | 		if ( $catch ) {
 95 | 			# This works like given($error), but is backwards compatible and
 96 | 			# sets $_ in the dynamic scope for the body of C<$catch>
 97 | 			for ($error) {
 98 | 				return $catch->($error);
 99 | 			}
100 | 
101 | 			# in case when() was used without an explicit return, the C<for>
102 | 			# loop will be aborted and there's no useful return value
103 | 		}
104 | 
105 | 		return;
106 | 	} else {
107 | 		# no failure, $@ is back to what it was, everything is fine
108 | 		return $wantarray ? @ret : $ret[0];
109 | 	}
110 | }
111 | 
112 | sub catch (&;@) {
113 | 	my ( $block, @rest ) = @_;
114 | 
115 | 	return (
116 | 		bless(\$block, 'Try::Tiny::Catch'),
117 | 		@rest,
118 | 	);
119 | }
120 | 
121 | sub finally (&;@) {
122 | 	my ( $block, @rest ) = @_;
123 | 
124 | 	return (
125 | 		bless(\$block, 'Try::Tiny::Finally'),
126 | 		@rest,
127 | 	);
128 | }
129 | 
130 | sub Try::Tiny::ScopeGuard::DESTROY {
131 | 	my $self = shift;
132 | 	$$self->();
133 | }
134 | 
135 | __PACKAGE__
136 | 
137 | __END__
138 | 
139 | =pod
140 | 
141 | =head1 NAME
142 | 
143 | Try::Tiny - minimal try/catch with proper localization of $@
144 | 
145 | =head1 SYNOPSIS
146 | 
147 | 	# handle errors with a catch handler
148 | 	try {
149 | 		die "foo";
150 | 	} catch {
151 | 		warn "caught error: $_";
152 | 	};
153 | 
154 | 	# just silence errors
155 | 	try {
156 | 		die "foo";
157 | 	};
158 | 
159 | =head1 DESCRIPTION
160 | 
161 | This module provides bare bones C<try>/C<catch>/C<finally> statements that are designed to
162 | minimize common mistakes with eval blocks, and NOTHING else.
163 | 
164 | This is unlike L<TryCatch> which provides a nice syntax and avoids adding
165 | another call stack layer, and supports calling C<return> from the try block to
166 | return from the parent subroutine. These extra features come at a cost of a few
167 | dependencies, namely L<Devel::Declare> and L<Scope::Upper> which are
168 | occasionally problematic, and the additional catch filtering uses L<Moose>
169 | type constraints which may not be desirable either.
170 | 
171 | The main focus of this module is to provide simple and reliable error handling
172 | for those having a hard time installing L<TryCatch>, but who still want to
173 | write correct C<eval> blocks without 5 lines of boilerplate each time.
174 | 
175 | It's designed to work as correctly as possible in light of the various
176 | pathological edge cases (see L<BACKGROUND>) and to be compatible with any style
177 | of error values (simple strings, references, objects, overloaded objects, etc).
178 | 
179 | If the try block dies, it returns the value of the last statement executed in
180 | the catch block, if there is one. Otherwise, it returns C<undef> in scalar
181 | context or the empty list in list context. The following two examples both
182 | assign C<"bar"> to C<$x>.
183 | 
184 | 	my $x = try { die "foo" } catch { "bar" };
185 | 
186 | 	my $x = eval { die "foo" } || "bar";
187 | 
188 | You can add finally blocks making the following true.
189 | 
190 | 	my $x;
191 | 	try { die 'foo' } finally { $x = 'bar' };
192 | 	try { die 'foo' } catch { warn "Got a die: $_" } finally { $x = 'bar' };
193 | 
194 | Finally blocks are always executed making them suitable for cleanup code
195 | which cannot be handled using local.
196 | 
197 | =head1 EXPORTS
198 | 
199 | All functions are exported by default using L<Exporter>.
200 | 
201 | If you need to rename the C<try>, C<catch> or C<finally> keyword consider using
202 | L<Sub::Import> to get L<Sub::Exporter>'s flexibility.
203 | 
204 | =over 4
205 | 
206 | =item try (&;@)
207 | 
208 | Takes one mandatory try subroutine, an optional catch subroutine & finally
209 | subroutine.
210 | 
211 | The mandatory subroutine is evaluated in the context of an C<eval> block.
212 | 
213 | If no error occurred the value from the first block is returned, preserving
214 | list/scalar context.
215 | 
216 | If there was an error and the second subroutine was given it will be invoked
217 | with the error in C<$_> (localized) and as that block's first and only
218 | argument.
219 | 
220 | Note that the error may be false, but if that happens the C<catch> block will
221 | still be invoked.
222 | 
223 | Once all execution is finished then the finally block if given will execute.
224 | 
225 | =item catch (&;$)
226 | 
227 | Intended to be used in the second argument position of C<try>.
228 | 
229 | Returns a reference to the subroutine it was given but blessed as
230 | C<Try::Tiny::Catch> which allows try to decode correctly what to do
231 | with this code reference.
232 | 
233 | 	catch { ... }
234 | 
235 | Inside the catch block the previous value of C<$@> is still available for use.
236 | This value may or may not be meaningful depending on what happened before the
237 | C<try>, but it might be a good idea to preserve it in an error stack.
238 | 
239 | =item finally (&;$)
240 | 
241 |   try     { ... }
242 |   catch   { ... }
243 |   finally { ... };
244 | 
245 | Or
246 | 
247 |   try     { ... }
248 |   finally { ... };
249 | 
250 | Or even
251 | 
252 |   try     { ... }
253 |   finally { ... }
254 |   catch   { ... };
255 | 
256 | Intended to be the second or third element of C<try>. Finally blocks are always
257 | executed in the event of a successful C<try> or if C<catch> is run. This allows
258 | you to locate cleanup code which cannot be done via C<local()> e.g. closing a file
259 | handle.
260 | 
261 | B<You must always do your own error handling in the finally block>. C<Try::Tiny> will
262 | not do anything about handling possible errors coming from code located in these
263 | blocks.
264 | 
265 | In the same way C<catch()> blesses the code reference this subroutine does the same
266 | except it bless them as C<Try::Tiny::Finally>.
267 | 
268 | =back
269 | 
270 | =head1 BACKGROUND
271 | 
272 | There are a number of issues with C<eval>.
273 | 
274 | =head2 Clobbering $@
275 | 
276 | When you run an eval block and it succeeds, C<$@> will be cleared, potentially
277 | clobbering an error that is currently being caught.
278 | 
279 | This causes action at a distance, clearing previous errors your caller may have
280 | not yet handled.
281 | 
282 | C<$@> must be properly localized before invoking C<eval> in order to avoid this
283 | issue.
284 | 
285 | More specifically, C<$@> is clobbered at the begining of the C<eval>, which
286 | also makes it impossible to capture the previous error before you die (for
287 | instance when making exception objects with error stacks).
288 | 
289 | For this reason C<try> will actually set C<$@> to its previous value (before
290 | the localization) in the beginning of the C<eval> block.
291 | 
292 | =head2 Localizing $@ silently masks errors
293 | 
294 | Inside an eval block C<die> behaves sort of like:
295 | 
296 | 	sub die {
297 | 		$@ = $_[0];
298 | 		return_undef_from_eval();
299 | 	}
300 | 
301 | This means that if you were polite and localized C<$@> you can't die in that
302 | scope, or your error will be discarded (printing "Something's wrong" instead).
303 | 
304 | The workaround is very ugly:
305 | 
306 | 	my $error = do {
307 | 		local $@;
308 | 		eval { ... };
309 | 		$@;
310 | 	};
311 | 
312 | 	...
313 | 	die $error;
314 | 
315 | =head2 $@ might not be a true value
316 | 
317 | This code is wrong:
318 | 
319 | 	if ( $@ ) {
320 | 		...
321 | 	}
322 | 
323 | because due to the previous caveats it may have been unset.
324 | 
325 | C<$@> could also be an overloaded error object that evaluates to false, but
326 | that's asking for trouble anyway.
327 | 
328 | The classic failure mode is:
329 | 
330 | 	sub Object::DESTROY {
331 | 		eval { ... }
332 | 	}
333 | 
334 | 	eval {
335 | 		my $obj = Object->new;
336 | 
337 | 		die "foo";
338 | 	};
339 | 
340 | 	if ( $@ ) {
341 | 
342 | 	}
343 | 
344 | In this case since C<Object::DESTROY> is not localizing C<$@> but still uses
345 | C<eval>, it will set C<$@> to C<"">.
346 | 
347 | The destructor is called when the stack is unwound, after C<die> sets C<$@> to
348 | C<"foo at Foo.pm line 42\n">, so by the time C<if ( $@ )> is evaluated it has
349 | been cleared by C<eval> in the destructor.
350 | 
351 | The workaround for this is even uglier than the previous ones. Even though we
352 | can't save the value of C<$@> from code that doesn't localize, we can at least
353 | be sure the eval was aborted due to an error:
354 | 
355 | 	my $failed = not eval {
356 | 		...
357 | 
358 | 		return 1;
359 | 	};
360 | 
361 | This is because an C<eval> that caught a C<die> will always return a false
362 | value.
363 | 
364 | =head1 SHINY SYNTAX
365 | 
366 | Using Perl 5.10 you can use L<perlsyn/"Switch statements">.
367 | 
368 | The C<catch> block is invoked in a topicalizer context (like a C<given> block),
369 | but note that you can't return a useful value from C<catch> using the C<when>
370 | blocks without an explicit C<return>.
371 | 
372 | This is somewhat similar to Perl 6's C<CATCH> blocks. You can use it to
373 | concisely match errors:
374 | 
375 | 	try {
376 | 		require Foo;
377 | 	} catch {
378 | 		when (/^Can't locate .*?\.pm in \@INC/) { } # ignore
379 | 		default { die $_ }
380 | 	};
381 | 
382 | =head1 CAVEATS
383 | 
384 | =over 4
385 | 
386 | =item *
387 | 
388 | C<@_> is not available, you need to name your args:
389 | 
390 | 	sub foo {
391 | 		my ( $self, @args ) = @_;
392 | 		try { $self->bar(@args) }
393 | 	}
394 | 
395 | =item *
396 | 
397 | C<return> returns from the C<try> block, not from the parent sub (note that
398 | this is also how C<eval> works, but not how L<TryCatch> works):
399 | 
400 | 	sub bar {
401 | 		try { return "foo" };
402 | 		return "baz";
403 | 	}
404 | 
405 | 	say bar(); # "baz"
406 | 
407 | =item *
408 | 
409 | C<try> introduces another caller stack frame. L<Sub::Uplevel> is not used. L<Carp>
410 | will report this when using full stack traces. This lack of magic is considered
411 | a feature.
412 | 
413 | =item *
414 | 
415 | The value of C<$_> in the C<catch> block is not guaranteed to be the value of
416 | the exception thrown (C<$@>) in the C<try> block.  There is no safe way to
417 | ensure this, since C<eval> may be used unhygenically in destructors.  The only
418 | guarantee is that the C<catch> will be called if an exception is thrown.
419 | 
420 | =item *
421 | 
422 | The return value of the C<catch> block is not ignored, so if testing the result
423 | of the expression for truth on success, be sure to return a false value from
424 | the C<catch> block:
425 | 
426 | 	my $obj = try {
427 | 		MightFail->new;
428 | 	} catch {
429 | 		...
430 | 
431 | 		return; # avoid returning a true value;
432 | 	};
433 | 
434 | 	return unless $obj;
435 | 
436 | =back
437 | 
438 | =head1 SEE ALSO
439 | 
440 | =over 4
441 | 
442 | =item L<TryCatch>
443 | 
444 | Much more feature complete, more convenient semantics, but at the cost of
445 | implementation complexity.
446 | 
447 | =item L<autodie>
448 | 
449 | Automatic error throwing for builtin functions and more. Also designed to
450 | work well with C<given>/C<when>.
451 | 
452 | =item L<Throwable>
453 | 
454 | A lightweight role for rolling your own exception classes.
455 | 
456 | =item L<Error>
457 | 
458 | Exception object implementation with a C<try> statement. Does not localize
459 | C<$@>.
460 | 
461 | =item L<Exception::Class::TryCatch>
462 | 
463 | Provides a C<catch> statement, but properly calling C<eval> is your
464 | responsibility.
465 | 
466 | The C<try> keyword pushes C<$@> onto an error stack, avoiding some of the
467 | issues with C<$@>, but you still need to localize to prevent clobbering.
468 | 
469 | =back
470 | 
471 | =head1 LIGHTNING TALK
472 | 
473 | I gave a lightning talk about this module, you can see the slides (Firefox
474 | only):
475 | 
476 | L<http://nothingmuch.woobling.org/talks/takahashi.xul?data=try_tiny.txt>
477 | 
478 | Or read the source:
479 | 
480 | L<http://nothingmuch.woobling.org/talks/yapc_asia_2009/try_tiny.yml>
481 | 
482 | =head1 VERSION CONTROL
483 | 
484 | L<http://github.com/nothingmuch/try-tiny/>
485 | 
486 | =head1 AUTHOR
487 | 
488 | Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
489 | 
490 | =head1 COPYRIGHT
491 | 
492 | 	Copyright (c) 2009 Yuval Kogman. All rights reserved.
493 | 	This program is free software; you can redistribute
494 | 	it and/or modify it under the terms of the MIT license.
495 | 
496 | =cut
497 | 
498 | 


--------------------------------------------------------------------------------