Ok, so without knowing what the XS-replacement will look like and
without knowing what we're doing with filehandle-functions (is tell()
staying or does it get removed in favor of $fh.tell()) and a whole lot
of other stuff it's impossible to translate all of the Perl 5 functions
to Perl 6. However, what I've done is take a quick stab at creating at
least function signatures for everything that was in perlfunc and
implemented some of the functions that do not require any external junk
(e.g. reverse).
Some questions came up while I was doing this. Questions that came up a
lot, I put in comments at the front of the file. Other comments are
in-line and are marked with "XXX" for easy searching.
Anything that I think will be handled by internals or by the pre-coded
functions that are currently in parrot/languages/perl6/P6C/Builtins.pm,
I marked with "INTERNAL" for easy searching.
Please don't expect this to compile. It probably has typos and certainly
has masses of undefined class names (e.g. IO::Socket). It's really just
here to help me understand what I don't understand and to get some
questions on the table.
I'll keep updating this as more information about XS, filehandles, etc
become clear. There are also some functions (like split) that will
require my going over A5 with a fine-toothed comb before I proceed.
# Builtin functions
# XXX - This marker is used all over to indicate potential problems and
# quesitons about how Perl 6 works.
#
# High-level questions:
#
# When declaring:
# sub foo($a, $b) {...}
# and
# sub foo($a, *@rest) { ... }
# What is the correct order, and/or is this even valid? I need to know,
# given the way I did sort and reverse in order to handle exploded
# argument lists and arrays efficiently.
#
# What is happening to the IO functions? Do they just go away to be
# subsumed by the appropriate IO:: classes?
#
# Generally need to know how the interface ot libc will work, so
# that all of this junk can be implemented.
#
# Do I need to "@array is rw"? I would think not....
# An EMACS helper macro
# (defalias 'perl6-mockup (read-kbd-macro
# "C-a sub SPC M-d C-y ( C-e ) SPC { SPC UNIMP(\" C-y \") SPC }"))
sub UNIMP($func) { die "$0: Unimplemented: $func" }
sub NEVER($func) { die "$0: $func makes no sense in Perl 6" }
# Math
sub abs($num is int){ return $num>=0 ?? $num :: -$num }
sub accept($new is IO::Socket, $gen is IO::Socket){ UNIMP("accept") }
sub alarm($seconds is int){ UNIMP("alarm") }
sub atan2($y is number, $x is number) { UNIMP("atan2") }
sub bind($socket is IO::Socket, $name) { UNIMP("bind") }
sub binmode($fh is IO::Handle, $disc //= ':raw'){ UNIMP("binmode") }
sub bless($ref, $name //= undef){ NEVER("bless") }
sub caller($expr //= undef){ UNIMP("caller") }
sub chdir($path //= $ENV{HOME}){ UNIMP("chdir") }
sub chmod($mode is int, *@paths){
for @paths -> $_ {
UNIMP("chmod $mode, $_")
}
# XXX - Return value?
}
sub chomp($string is rw){
my $irs = $ {"/"};
if defined $irs {
if $irs.isa(Object) {
return undef;
} elsif $irs.length == 0 {
$string =~ s/ \n+ $ //;
return $0;
} else {
$string =~ s/<{"<[$irs]>"}>+$//;
return $0;
}
}
}
sub chomp() { UNIMP("chomp(LIST)") }
sub chomp(*@strings is rw) { UNIMP("chomp(LIST)") }
sub chop($string is rw) { UNIMP("chop") }
sub chop() { UNIMP("chop") }
sub chop(*@strings) { UNIMP("chop") }
sub chown($uid is int, $gid is int, *@files) {
for @files -> $_ {
UNIMP("chown $uid, $gid, $_");
}
# XXX Return value?
}
sub chr($num is int //= $_){ return pack 'C', $num } # XXX Not UNICODE
sub chroot($path //= $_){ UNIMP("chroot") }
sub close($fh is IO::Handle //= "XXX_defaulthandle") { UNIMP("close") }
sub closedir($dh is IO::DirHandle) { UNIMP("closedir") }
sub connect($socket is IO:Socket, $name) { UNIMP("connect") }
sub cos($num is number //= $_) { UNIMP("cos") }
sub acos($num is number //= $_) { atan2( sqrt(1 - ($num ** 2)), $num ) }
sub tan($num is number //= $_) { return sin($num) / cos($num) }
sub cos($num is number //= $_) { UNIMP("cos") }
sub crypt($plaintext, $salt) { UNIMP("crypt") }
sub dbmclose(%hash) { NEVER("dbmclose") }
sub dbmopen(%hash, $dbname, $mask) { NEVER("dbmopen") }
# INTERNAL defined
# INTERNAL delete
# INTERNAL die
# INTERNAL do
sub dump($label //= $_) { NEVER("dump") }
# INTERNAL each
sub eof($fh is IO::Handle //= "XXX_defaulthandle") { UNIMP("eof") }
sub eval(&code) {
warn "Perl 6 uses try for blocks";
return try(&code);
}
# INTERNAL eval(string)
sub exec($program, *@args) { UNIMP("exec") } # XXX exec $prog $argv0, $argv1...
# INTERNAL exists
# INTERNAL exit
sub exp($num is number //= $_) { UNIMP("exp") }
sub fcntl($fh is IO::Handle, $func, $scalar) { UNIMP("fcntl") }
sub fileno($fh is IO::Handle //= "XXX_defaulthandle") { UNIMP(fileno) }
sub flock($fh is IO::Handle, $operation) { UNIMP("flock") }
sub fork() { UNIMP("fork") }
sub format() { NEVER("format") }
sub formline($picture, *@list) { NEVER("formline") }
sub getc($fh is IO::Handle //= "XXX_defaulthandle") { UNIMP("getc") }
sub getlogin() { UNIMP("getlogin") }
sub getpeername($socket is IO::Socket) { UNIMP("getpeername") }
sub getpgrp($pid is int) { UNIMP("getpgrp") }
sub getppid() { UNIMP("getppid") }
sub getpriority($which is int, $who is int) { UNIMP("getpriority") }
sub getpwnam($name) { UNIMP("getpwnam") }
sub getgrnam($name) { UNIMP("getgrnam") }
sub gethostbyname($name) { UNIMP("gethostbyname") }
sub getnetbyname($name) { UNIMP("getnetbyname") }
sub getprotobyname($name) { UNIMP("getprotobyname") }
sub getpwuid($uid is int) { UNIMP("getpwuid") }
sub getgrgid($gid is int) { UNIMP("getgrgid") }
sub getservbyname($name, $proto) { UNIMP("getservbyname") }
sub gethostbyaddr($addr, $addrtype) { UNIMP("gethostbyaddr") }
sub getnetbyaddr($addr, $addrtype) { UNIMP("getnetbyaddr") }
sub getprotobynumber($number is int) { UNIMP("getprotobynumber") }
sub getservbyport($port is int, $proto) { UNIMP("getservbyport") }
sub getpwent() { UNIMP("getpwent") }
sub getgrent() { UNIMP("getgrent") }
sub gethostent() { UNIMP("gethostent") }
sub getnetent() { UNIMP("getnetent") }
sub getprotoent() { UNIMP("getprotoent") }
sub getservent() { UNIMP("getservent") }
sub setpwent() { UNIMP("setpwent") }
sub setgrent() { UNIMP("setgrent") }
sub sethostent($stayopen is bool) { UNIMP("sethostent") }
sub setnetent($stayopen is bool) { UNIMP("setnetent") }
sub setprotoent($stayopen is bool) { UNIMP("setprotoent") }
sub setservent($stayopen is bool) { UNIMP("setservent") }
sub endpwent() { UNIMP("endpwent") }
sub endgrent() { UNIMP("endgrent") }
sub endhostent() { UNIMP("endhostent") }
sub endnetent() { UNIMP("endnetent") }
sub endprotoent() { UNIMP("endprotoent") }
sub endservent() { UNIMP("endservent") }
sub getsockname($socket is IO::Socket) { UNIMP("getsockname") }
sub getsockopt($socket is IO::Socket,$level,$optname) { UNIMP("getsockopt") }
sub glob($string //= $_) { UNIMP("glob") }
sub gmtime($unixtime is number) { UNIMP("gmtime") }
# INTERNAL goto
sub grep(&code, *@list) {
my @newlist;
for @list -> $_ {
push @newlist, $_ if &code(); # XXX - How does code get $_?
}
return @newlist;
}
sub hex($string) {
my($tmp) = ($string =~ /^[0x]?(<[a-fA-F0-9]>+)/);
return 0 unless defined($hex) && $hex.length;
my $bit = 0;
my $result = 0;
for(my $i = $tmp.length-1;$i>=0;$i--) {
my $n = substr($tmp,$i,1);
given $n {
when 'a' .. 'f', 'A' .. 'F' {
$n = ord(lc $n)-ord('a')+10;
}
when '0' .. '9' {
$n = +$n;
}
}
$result += $n * (16**$bit++);
}
return $tmp;
}
sub index($string, $substr, $pos is int //= 0) {
# XXX - slow dumb way
for(my $i = $pos; $i < $string.length; $i++) {
return $i if substr($string,$i,$substr.length) eq $substr;
}
return -1;
}
sub int($num is int //= $_) { $num }
sub ioctl($fh is IO::Handle,$function,$scalar) { UNIMP("ioctl") }
sub join($sep, *@list) {
return '' unless @list.length;
my $result = @list[0];
for(my $i=1;$i <= @list.length;$i++) {
$result _= $sep _ @list[$i];
}
return $result;
}
# INTERNAL keys
sub kill($signal, *@procs) { UNIMP("kill") }
# INTERNAL last
sub lc($string //= $_) { $string =~ tr/A-Z/a-z/; } # XXX NOT UNICODE
sub lcfirst($string //= $_) {
given $string.length {
0 { return '' }
1 { return lc $string }
default { return lc($string[0]) _ substr($string,1) }
}
}
sub length($string //= $_) { return $string.length }
sub link($oldfile,$newfile) { UNIMP("link") }
sub listen($socket is IO::Socket,$queuesize) { UNIMP("listen") }
sub local($var) { NEVER("local") }
sub localtime($thetime //= time()) { UNIMP("localtime") }
# INTERNAL lock
sub log($num is int) { UNIMP("log") }
sub log10($num is int) { return log($num)/log(10) }
sub lstat($fh is IO::Handle) { UNIMP("lstat") }
sub lstat($path //= $_) { UNIMP("lstat") }
# INTERNAL m
sub map(&code, *@list) {
my @result;
for @list -> $_ {
push @result, &code(); # XXX how does &code get $_
}
return @result;
}
sub mkdir($file, $mask is int //= 0777) { UNIMP("mkdir") }
sub msgctl($id,$cmd,$arg) { UNIMP("msgctl") }
sub msgget($key,$flags) { UNIMP("msgget") }
sub msgrcv($id,$var,$size,$type,$flags) { UNIMP("msgrcv") }
sub msgsnd($id,$msg,$flags) { UNIMP("msgsnd") }
# INTERNAL my
# INTERNAL next
# INTERNAL no
sub oct($string //= $_) {
given $string {
# XXX - handle "0b"
when /^0x/ {
return hex($string);
}
default {
my $return = 0;
my $bit = 0;
for(my $i = $tmp.length-1;$i>=0;$i--) {
my $n = substr($tmp,$i,1);
# Avoid overflow for leading 0
$return += $n * (8**$bit++) if $n;
}
return $return;
}
}
}
sub open(*@args) { NEVER("open") } # XXX Will handle objects be forced?
sub opendir(*@args) { NEVER("opendir") } # XXX see open
sub ord($char //= $_) { return unpack 'C', $char }
# INTERNAL our
sub pack($template,*@args) { UNIMP("pack") }
# INTERNAL package
sub pipe($readhandle,$writehandle) { UNIMP("pipe") } # XXX gone?
sub pop(@list) {
return undef if @list.length == 0;
return delete @list[@list.length - 1];
}
sub pos($scalar //= $_) { NEVER("pos") } # pos is now a method on $0
# INTERNAL print
sub printf($format, *@list) { print(sprintf($format, *@list)) }
sub prototype($function) { UNIMP("prototype") }
sub push(@array,*@list) {
for @list -> $_ {
@array[@array.length] = $_;
}
}
# INTERNAL q, qq, qw
# XXX - how do I do quote-like operators? I know I saw someone say...
# Need to do: qr (NEVER("qr")) and qx
sub quotemeta($string //= $_) { $string =~ s:each/(\W)/\\$1/ } # XXX ?
sub rand($num is int //= 1) { UNIMP("rand") }
sub read($fh,$buf,$len,$off //= 0) { UNIMP("read") }
sub readdir($dh is IO::DirHandle) { UNIMP("readdir") }
sub readline($fh is IO::Handle) { UNIMP("readline") }
sub readlink($path //= $_) { UNIMP("readlink") }
sub readpipe($command) { UNIMP("readpipe") }
sub recv($socket is IO::Socket,$buf,$len,$flags) { UNIMP("recv") }
# INTERNAL redo
sub ref($scalar //= $_) { UNIMP("ref") } # XXX Never?
sub rename($oldname,$newname) { UNIMP("rename") }
sub reset($tmp //= $_) { NEVER("reset") }
# INTERNAL return
sub reverse(@list) {
my @r;
my $last = @list.length - 1;
for(my $i=$last;$i >= 0;$i++) {
@r[$last-$i] = @list[$i];
}
return *@r;
}
sub reverse(*@list) { return reverse @list }
sub rewinddir($dh is IO::DirHandle) { UNIMP("rewinddir") }
sub rindex($string, $substr, $pos //= 0) {
# XXX - slow dumb way
for(my $i = $string.length-1; $i >= $pos; $i--) {
return $i if substr($string,$i,$substr.length) eq $substr;
}
return -1;
}
sub rmdir($path //= $_) { UNIMP("rmdir") }
# INTERNAL s
sub scalar($value) { return $value }
sub seek($fh is IO::Handle,$pos, $whence) { UNIMP("seek") }
sub seekdir($dh is IO::DirHandle,$pos is int) { UNIMP("seekdir") }
sub select($fh) { UNIMP("select") }
sub select() { UNIMP("select") }
sub select($rbits,$wbits,$ebits,$timeout is number) { UNIMP("select") }
sub semctl($id,$semnum,$cmd,$arg) { UNIMP("semctl") }
sub semget($key,$nsems,$flags) { UNIMP("semget") }
sub semop($key,$opstring) { UNIMP("semop") }
sub send($socket is IO::Socket,$msg,$flags,$to //= undef) { UNIMP("send") }
sub setpgrp($pid,$pgrp) { UNIMP("setpgrp") }
sub setpriority($which,$who,$priority) { UNIMP("setpriority") }
sub setsockopt($socket is IO::Socket,$level,$optname,$optval) { UNIMP("setsockopt") }
sub shift(@list) {
return undef if @list.length == 0;
return delete @list[@list.length-1];
}
sub shmctl($id,$cmd,$arg) { UNIMP("shmctl") }
sub shmget($key,$size,$flags) { UNIMP("shmget") }
sub shmread($id,$var,$pos,$size) { UNIMP("shmread") }
sub shmwrite($id,$string,$pos,$size) { UNIMP("shmwrite") }
sub shutdown($socket is IO::Socket,$how is int) { UNIMP("shutdown") }
sub sin($num is number //= $_) { UNIMP("sin") }
sub asin($num is number //= $_) { atan2($num, sqrt(1 - $num * $num)) }
# INTERNAL sleep
#sub sleep($seconds is int) { UNIMP("sleep") }
sub sleep() { UNIMP("sleep") } # Never wake up
sub socket($socket is IO::Socket is rw,$domain,$type,$protocol) { UNIMP("socket") }
sub socketpair($socket1,$socket2,$domain,$type,$protocol) { NEVER("socketpair") }
sub sort(&code, @list) { UNIMP("sort") }
sub sort(&code, *@list) { return sort &code, @list }
sub sort(*@list) { return sort sub($a,$b){$a cmp $b}, @list }
sub splice(@array,$off is int //= 0,$len is int //= undef, *@list) {
# XXX - A9 is supposed to tell us how slicing works!
if !defined($len) || $len > (@array.length-$off) {
$len = @array.length-$off;
}
# XXX - Too tired to type -ajs
UNIMP("splice");
# return @old;
}
sub split(rx $pat,$string //= $_, $limit //= undef) {
# XXX - split may just fall out of regex syntax.. more thought needed
UNIMP("split");
}
sub split($match //= undef, $string //= $_, $limit //= undef) {
$match = (defined($match) ?? rx/$match/ :: rx/\s+/);
return split $match, $string, $limit;
}
sub sprintf($format, *@list) { UNIMP("sprintf") }
sub sqrt($num is number //= $_) { UNIMP("sqrt") }
sub srand($seed is int //= undef) { UNIMP("srand") }
sub stat($path //= $_) { UNIMP("stat") }
sub study($scalar //= $_) { NEVER("study") }
# INTERNAL sub
# INTERNAL substr
sub symlink($oldfile,$newfile) { UNIMP("symlink") }
sub syscall(*@list) { UNIMP("syscall") }
sub sysopen(*@list) { UNIMP("sysopen") }
sub sysread(*@list) { UNIMP("sysread") }
sub sysseek(*@list) { UNIMP("sysseek") }
# XXX system($program @list)
sub system(*@list) { UNIMP("system") }
sub syswrite(*@list) { UNIMP("syswrite") }
sub tell($fh is IO::Handle //= "XXX_defaulthandle") { UNIMP("tell") }
sub telldir($dh is IO::DirHandle) { UNIMP("telldir") }
# XXX tie, tied??
# INTERNAL time
sub times() { UNIMP("times") }
# XXX tr??
sub truncate($fh is IO::Handle,$len) { UNIMP("truncate") }
sub truncate($path,$len) { UNIMP("truncate") }
sub uc($string //= $_) { $string =~ tr/a-z/A-Z/; } # XXX NOT UNICODE
sub ucfirst($string //= $_) {
given $string.length {
0 { return '' }
1 { return uc $string }
default { return uc($string[0]) _ substr($string,1) }
}
}
sub umask($newmask is int) { UNIMP("umask") }
sub umask() { UNIMP("umask") }
# INTERNAL undef
sub unlink($path //= $_) { UNIMP("unlink") }
sub unpack($template,$value) { UNIMP("unpack") }
sub untie($var) { UNIMP("untie") }
sub unshift(@array is rw,*@list) { @array = (*@list, *@array) }
# INTERNAL use
sub utime(@paths) { UNIMP("utime") }
sub utime(*@paths) { utime(@paths) }
# INTERNAL values
sub vec($bitvec,$off is int,$bits is int) { UNIMP("vec") }
sub wait() { UNIMP("wait") }
sub waitpid($pid is int,$flags is int) { UNIMP("waitpid") }
# INTERNAL wantarray
sub warn(*@list) { UNIMP("warn") }
sub write() { NEVER("write") }
# INTERNAL y
