CDS
view release on metacpan or search on metacpan
sub collectBackup {
my $o = shift;
my $label = shift;
my $value = shift;
$o->{status} = 'backup';
}
sub collectIdle {
my $o = shift;
my $label = shift;
my $value = shift;
$o->{status} = 'idle';
}
sub collectRevoked {
my $o = shift;
my $label = shift;
my $value = shift;
$o->{status} = 'revoked';
}
sub collectStore {
my $o = shift;
my $label = shift;
my $value = shift;
push @{$o->{accountTokens}}, CDS::AccountToken->new($value, $o->{actorHash});
delete $o->{actorHash};
}
sub new {
my $class = shift;
my $actor = shift;
bless {actor => $actor, ui => $actor->ui} }
# END AUTOGENERATED
# HTML FOLDER NAME actor-group
# HTML TITLE Actor group
sub help {
my $o = shift;
my $cmd = shift;
my $ui = $o->{ui};
$ui->space;
$ui->command('cds show actor group');
$ui->p('Shows all members of our actor group and the entrusted keys.');
$ui->space;
$ui->command('cds join ACCOUNT*');
$ui->command('cds join ACTOR on STORE');
$ui->p('Adds a member to our actor group. To complete the association, the new member must join us, too.');
$ui->space;
$ui->command('cds set member ACTOR* active');
$ui->command('cds set member ACTOR* backup');
$ui->command('cds set member ACTOR* idle');
$ui->command('cds set member ACTOR* revoked');
$ui->p('Changes the status of a member to one of the following:');
$ui->p($ui->bold('Active members'), ' share the group data among themselves, and are advertised to receive messages.');
$ui->p($ui->bold('Backup members'), ' share the group data (like active members), but are publicly advertised as not processing messages (like idle members). This is suitable for backup actors.');
$ui->p($ui->bold('Idle members'), ' are part of the group, but advertised as not processing messages. They generally do not have the latest group data, and may have no group data at all. Idle members may reactivate themselves, or get reactivated by ...
$ui->p($ui->bold('Revoked members'), ' have explicitly been removed from the group, e.g. because their private key (or device) got lost. Revoked members can be reactivated by any active member of the group.');
$ui->p('Note that changing the status does not start or stop the corresponding actor, but just change how it is regarded by others. The status of each member should reflect its actual behavior.');
$ui->space;
$ui->p('After modifying the actor group members, you should "cds announce" yourself to publish the changes.');
$ui->space;
}
sub show {
my $o = shift;
my $cmd = shift;
my $hasMembers = 0;
for my $actorSelector ($o->{actor}->actorGroupSelector->children) {
my $record = $actorSelector->record;
my $hash = $record->child('hash')->hashValue // next;
next if substr($hash->bytes, 0, length $actorSelector->label) ne $actorSelector->label;
my $storeUrl = $record->child('store')->textValue;
my $revisionText = $o->{ui}->niceDateTimeLocal($actorSelector->revision);
$o->{ui}->line($o->{ui}->gray($revisionText), ' ', $o->coloredType7($actorSelector), ' ', $hash->hex, ' on ', $storeUrl);
$hasMembers = 1;
}
return if $hasMembers;
$o->{ui}->line($o->{ui}->blue('(just you)'));
}
sub type {
my $o = shift;
my $actorSelector = shift; die 'wrong type '.ref($actorSelector).' for $actorSelector' if defined $actorSelector && ref $actorSelector ne 'CDS::Selector';
my $groupData = $actorSelector->child('group data')->isSet;
my $active = $actorSelector->child('active')->isSet;
my $revoked = $actorSelector->child('revoked')->isSet;
return
$revoked ? 'revoked' :
$active && $groupData ? 'active' :
$groupData ? 'backup' :
$active ? 'weird' :
'idle';
}
sub coloredType7 {
my $o = shift;
my $actorSelector = shift; die 'wrong type '.ref($actorSelector).' for $actorSelector' if defined $actorSelector && ref $actorSelector ne 'CDS::Selector';
my $groupData = $actorSelector->child('group data')->isSet;
my $active = $actorSelector->child('active')->isSet;
my $revoked = $actorSelector->child('revoked')->isSet;
return
$revoked ? $o->{ui}->red('revoked') :
$active && $groupData ? $o->{ui}->green('active ') :
$groupData ? $o->{ui}->blue('backup ') :
$active ? $o->{ui}->orange('weird ') :
$o->{ui}->gray('idle ');
}
sub joinMember {
my $o = shift;
my $cmd = shift;
$o->{accountTokens} = [];
sub collectStore {
my $o = shift;
my $label = shift;
my $value = shift;
$o->{store} = $value;
}
sub new {
my $class = shift;
my $actor = shift;
bless {actor => $actor, ui => $actor->ui} }
# END AUTOGENERATED
# HTML FOLDER NAME show-tree
# HTML TITLE Show trees
sub help {
my $o = shift;
my $cmd = shift;
my $ui = $o->{ui};
$ui->space;
$ui->command('cds show tree OBJECT*');
$ui->command('cds show tree HASH* on STORE');
$ui->p('Downloads a tree, and shows the tree hierarchy. If an object has been traversed before, it is listed as "reported above".');
$ui->space;
$ui->command('cds show tree HASH*');
$ui->p('As above, but uses the selected store.');
$ui->space;
}
sub showTree {
my $o = shift;
my $cmd = shift;
$o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
$o->{objectTokens} = [];
$o->{hashes} = [];
$cmd->collect($o);
# Process all trees
for my $objectToken (@{$o->{objectTokens}}) {
$o->{ui}->space;
$o->process($objectToken->hash, $objectToken->cliStore);
}
if (scalar @{$o->{hashes}}) {
my $store = $o->{store} // $o->{actor}->preferredStore;
for my $hash (@{$o->{hashes}}) {
$o->{ui}->space;
$o->process($hash, $store);
}
}
# Report the total size
my $totalSize = 0;
my $totalDataSize = 0;
map { $totalSize += $_->{size} ; $totalDataSize += $_->{dataSize} } values %{$o->{objects}};
$o->{ui}->space;
$o->{ui}->p(scalar keys %{$o->{objects}}, ' unique objects ', $o->{ui}->bold($o->{ui}->niceFileSize($totalSize)), $o->{ui}->gray(' (', $o->{ui}->niceFileSize($totalSize - $totalDataSize), ' header and ', $o->{ui}->niceFileSize($totalDataSize), ' dat...
$o->{ui}->pRed(scalar keys %{$o->{missingObjects}}, ' or more objects are missing') if scalar keys %{$o->{missingObjects}};
$o->{ui}->space;
}
sub process {
my $o = shift;
my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
my $store = shift;
my $hashHex = $hash->hex;
# Check if we retrieved this object before
if (exists $o->{objects}->{$hashHex}) {
$o->{ui}->line($hash->hex, ' reported above') ;
return 1;
}
# Retrieve the object
my ($object, $storeError) = $store->get($hash, $o->{keyPairToken}->keyPair);
return if defined $storeError;
if (! $object) {
$o->{missingObjects}->{$hashHex} = 1;
return $o->{ui}->line($hashHex, ' ', $o->{ui}->red('is missing'));
}
# Display
my $size = $object->byteLength;
$o->{objects}->{$hashHex} = {size => $size, dataSize => length $object->data};
$o->{ui}->line($hashHex, ' ', $o->{ui}->bold($o->{ui}->niceFileSize($size)), ' ', $o->{ui}->gray($object->hashesCount, ' hashes'));
# Process all children
$o->{ui}->pushIndent;
foreach my $hash ($object->hashes) {
$o->process($hash, $store) // return;
}
$o->{ui}->popIndent;
return 1;
}
# BEGIN AUTOGENERATED
package CDS::Commands::StartHTTPServer;
sub register {
my $class = shift;
my $cds = shift;
my $help = shift;
my $node000 = CDS::Parser::Node->new(0);
my $node001 = CDS::Parser::Node->new(0);
my $node002 = CDS::Parser::Node->new(0);
my $node003 = CDS::Parser::Node->new(0);
my $node004 = CDS::Parser::Node->new(0);
my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
my $node006 = CDS::Parser::Node->new(0);
my $node007 = CDS::Parser::Node->new(0);
my $node008 = CDS::Parser::Node->new(0);
my $node009 = CDS::Parser::Node->new(1);
my $node010 = CDS::Parser::Node->new(0);
my $node011 = CDS::Parser::Node->new(1);
my $node012 = CDS::Parser::Node->new(0);
my $node013 = CDS::Parser::Node->new(0);
my $node014 = CDS::Parser::Node->new(0);
my $node015 = CDS::Parser::Node->new(0);
my $node016 = CDS::Parser::Node->new(1);
my $node017 = CDS::Parser::Node->new(0);
my $node018 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&startHttpServer});
$cds->addArrow($node001, 1, 0, 'start');
$help->addArrow($node000, 1, 0, 'http');
$node000->addArrow($node005, 1, 0, 'server');
$node001->addArrow($node002, 1, 0, 'http');
$node002->addArrow($node003, 1, 0, 'server');
$node003->addArrow($node004, 1, 0, 'for');
$node004->addArrow($node006, 1, 0, 'STORE', \&collectStore);
$node006->addArrow($node007, 1, 0, 'on');
$node007->addArrow($node008, 1, 0, 'port');
$node008->addArrow($node009, 1, 0, 'PORT', \&collectPort);
$node009->addArrow($node010, 1, 0, 'at');
$node009->addDefault($node011);
$node010->addArrow($node011, 1, 0, 'TEXT', \&collectText);
$node011->addArrow($node012, 1, 0, 'with');
$node011->addDefault($node016);
$node012->addArrow($node013, 1, 0, 'static');
$node013->addArrow($node014, 1, 0, 'files');
$node014->addArrow($node015, 1, 0, 'from');
$node015->addArrow($node016, 1, 0, 'FOLDER', \&collectFolder);
$node016->addArrow($node017, 1, 0, 'for');
$node016->addDefault($node018);
$node017->addArrow($node018, 1, 0, 'everybody', \&collectEverybody);
}
sub startHttpServer {
my $o = shift;
my $cmd = shift;
$cmd->collect($o);
my $httpServer = CDS::HTTPServer->new($o->{port});
$httpServer->setLogger(CDS::Commands::StartHTTPServer::Logger->new($o->{ui}));
$httpServer->setCorsAllowEverybody($o->{corsAllowEverybody});
$httpServer->addHandler(CDS::HTTPServer::StoreHandler->new($o->{root} // '/', $o->{store}));
$httpServer->addHandler(CDS::HTTPServer::IdentificationHandler->new($o->{root} // '/')) if ! defined $o->{staticFolder};
$httpServer->addHandler(CDS::HTTPServer::StaticFilesHandler->new('/', $o->{staticFolder}, 'index.html')) if defined $o->{staticFolder};
eval { $httpServer->run; };
if ($@) {
my $error = $@;
$error = $1 if $error =~ /^(.*?)( at |\n)/;
$o->{ui}->space;
$o->{ui}->p('Failed to run server on port '.$o->{port}.': '.$error);
$o->{ui}->space;
}
}
package CDS::Commands::StartHTTPServer::Logger;
sub new {
my $class = shift;
my $ui = shift;
return bless {ui => $ui};
}
sub onServerStarts {
my $o = shift;
my $port = shift;
my $ui = $o->{ui};
$ui->space;
$ui->line($o->{ui}->gray($ui->niceDateTimeLocal), ' ', $ui->green('Server ready at http://localhost:', $port));
}
sub onRequestStarts {
my $o = shift;
my $request = shift;
}
sub onRequestError {
my $o = shift;
my $request = shift;
my $ui = $o->{ui};
$ui->line($o->{ui}->gray($ui->niceDateTimeLocal), ' ', $ui->blue($ui->left(15, $request->peerAddress)), ' ', $request->method, ' ', $request->path, ' ', $ui->red(@_));
}
sub onRequestDone {
my $o = shift;
my $request = shift;
my $responseCode = shift;
my $ui = $o->{ui};
$ui->line($o->{ui}->gray($ui->niceDateTimeLocal), ' ', $ui->blue($ui->left(15, $request->peerAddress)), ' ', $request->method, ' ', $request->path, ' ', $ui->bold($responseCode));
}
# BEGIN AUTOGENERATED
package CDS::Commands::Transfer;
sub register {
my $class = shift;
my $cds = shift;
my $help = shift;
my $node000 = CDS::Parser::Node->new(0);
my $node001 = CDS::Parser::Node->new(0);
my $node002 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
my $node003 = CDS::Parser::Node->new(0);
my $node004 = CDS::Parser::Node->new(0);
my $node005 = CDS::Parser::Node->new(0);
my $node006 = CDS::Parser::Node->new(0);
my $node007 = CDS::Parser::Node->new(0);
my $node008 = CDS::Parser::Node->new(0);
my $node009 = CDS::Parser::Node->new(0);
my $node010 = CDS::Parser::Node->new(0);
my $node011 = CDS::Parser::Node->new(0);
my $node012 = CDS::Parser::Node->new(0);
my $node013 = CDS::Parser::Node->new(0);
my $node014 = CDS::Parser::Node->new(0);
my $node015 = CDS::Parser::Node->new(0);
my $node016 = CDS::Parser::Node->new(0);
my $node017 = CDS::Parser::Node->new(1);
my $node018 = CDS::Parser::Node->new(0);
my $node019 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&transfer});
$cds->addArrow($node000, 1, 0, 'thoroughly');
$cds->addArrow($node001, 0, 0, 'leniently');
$cds->addDefault($node003);
$cds->addArrow($node003, 1, 0, 'leniently', \&collectLeniently);
$cds->addArrow($node003, 1, 0, 'thoroughly', \&collectThoroughly);
$help->addArrow($node002, 1, 0, 'transfer');
$node000->addArrow($node003, 1, 0, 'leniently', \&collectLeniently1);
$node001->addArrow($node003, 0, 0, 'thoroughly', \&collectLeniently1);
$node003->addArrow($node004, 1, 0, 'transfer');
$node004->addDefault($node005);
$node004->addDefault($node006);
$node004->addDefault($node007);
$node004->addDefault($node008);
$node004->addArrow($node009, 1, 0, 'message');
$node004->addDefault($node010);
$node004->addArrow($node011, 1, 0, 'private');
$node004->addArrow($node012, 1, 0, 'public');
$node004->addArrow($node013, 1, 0, 'all', \&collectAll);
$node004->addArrow($node013, 0, 0, 'messages', \&collectMessages);
$node004->addArrow($node013, 0, 0, 'private', \&collectPrivate);
$node004->addArrow($node013, 0, 0, 'public', \&collectPublic);
$node005->addArrow($node005, 1, 0, 'HASH', \&collectHash);
$node005->addArrow($node017, 1, 0, 'HASH', \&collectHash);
$node006->addArrow($node006, 1, 0, 'OBJECT', \&collectObject);
$node006->addArrow($node017, 1, 0, 'OBJECT', \&collectObject);
$node007->addArrow($node007, 1, 0, 'ACCOUNT', \&collectAccount);
$node007->addArrow($node017, 1, 0, 'ACCOUNT', \&collectAccount);
$node008->addArrow($node008, 1, 0, 'BOX', \&collectBox);
$node008->addArrow($node017, 1, 0, 'BOX', \&collectBox);
$node009->addArrow($node013, 1, 0, 'box', \&collectMessages);
my %done;
for my $boxToken (@{$o->{boxTokens}}) {
my $actorHash = $boxToken->accountToken->actorHash;
next if $done{$actorHash->bytes};
$done{$actorHash->bytes} = 1;
push @{$o->{objectTokens}}, CDS::ObjectToken->new($boxToken->accountToken->cliStore, $actorHash);
}
# Prepare the destination stores
my $toStores = [];
for my $toStore (@{$o->{toStores}}) {
push @$toStores, {store => $toStore, storeError => undef, needed => [1]};
}
# Print the stores
$o->{ui}->space;
my $n = scalar @$toStores;
for my $i (0 .. $n - 1) {
my $toStore = $toStores->[$i];
$o->{ui}->line($o->{ui}->gray(' │' x $i, ' ┌', '──' x ($n - $i), ' ', $toStore->{store}->url));
}
# Process all trees
$o->{objects} = {};
$o->{missingObjects} = {};
for my $objectToken (@{$o->{objectTokens}}) {
$o->{ui}->line($o->{ui}->gray(' │' x $n));
$o->process($objectToken->hash, $objectToken->cliStore, $toStores, 1);
}
# Process all accounts
my $keyPair = $o->{keyPairToken}->keyPair;
for my $boxToken (@{$o->{boxTokens}}) {
$o->{ui}->line($o->{ui}->gray(' │' x $n));
$o->{ui}->line($o->{ui}->gray(' │' x $n, ' Transferring ', $boxToken->boxLabel, ' box of ', $boxToken->accountToken->actorHash->hex));
my ($hashes, $listError) = $boxToken->accountToken->cliStore->list($boxToken->accountToken->actorHash, $boxToken->boxLabel, 0, $keyPair);
next if $listError;
for my $hash (@$hashes) {
$o->process($hash, $boxToken->accountToken->cliStore, $toStores, 1) // next;
for my $toStore (@$toStores) {
next if defined $toStore->{storeError};
$toStore->{storeError} = $toStore->{store}->add($boxToken->accountToken->actorHash, $boxToken->boxLabel, $hash, $keyPair);
}
}
}
# Print the stores again, with their errors
$o->{ui}->line($o->{ui}->gray(' │' x $n));
for my $i (reverse 0 .. $n - 1) {
my $toStore = $toStores->[$i];
$o->{ui}->line($o->{ui}->gray(' │' x $i, ' └', '──' x ($n - $i), ' ', $toStore->{store}->url), ' ', defined $toStore->{storeError} ? $o->{ui}->red($toStore->{storeError}) : '');
}
# Report the total size
my $totalSize = 0;
my $totalDataSize = 0;
map { $totalSize += $_->{size} ; $totalDataSize += $_->{dataSize} } values %{$o->{objects}};
$o->{ui}->space;
$o->{ui}->p(scalar keys %{$o->{objects}}, ' unique objects ', $o->{ui}->bold($o->{ui}->niceFileSize($totalSize)), ' ', $o->{ui}->gray($o->{ui}->niceFileSize($totalDataSize), ' data'));
$o->{ui}->pOrange(scalar keys %{$o->{missingObjects}}, ' or more objects are missing') if scalar keys %{$o->{missingObjects}};
$o->{ui}->space;
}
sub process {
my $o = shift;
my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
my $fromStore = shift;
my $toStores = shift;
my $depth = shift;
my $hashHex = $hash->hex;
my $keyPair = $o->{keyPairToken}->keyPair;
# Check if we retrieved this object before
if (exists $o->{objects}->{$hashHex}) {
$o->report($hash->hex, $toStores, $depth, $o->{ui}->green('copied before'));
return 1;
}
# Try to book the object on all active stores
my $countNeeded = 0;
my $hasActiveStore = 0;
for my $toStore (@$toStores) {
next if defined $toStore->{storeError};
$hasActiveStore = 1;
next if ! $o->{thoroughly} && ! $toStore->{needed}->[$depth - 1];
my ($found, $bookError) = $toStore->{store}->book($hash);
if (defined $bookError) {
$toStore->{storeError} = $bookError;
next;
}
next if $found;
$toStore->{needed}->[$depth] = 1;
$countNeeded += 1;
}
# Return if all stores reported an error
return if ! $hasActiveStore;
# Ignore existing subtrees at the destination unless "thoroughly" is set
if (! $o->{thoroughly} && ! $countNeeded) {
$o->report($hashHex, $toStores, $depth, $o->{ui}->gray('skipping subtree'));
return 1;
}
# Retrieve the object
my ($object, $getError) = $fromStore->get($hash, $keyPair);
return if defined $getError;
if (! defined $object) {
$o->{missingObjects}->{$hashHex} = 1;
$o->report($hashHex, $toStores, $depth, $o->{ui}->orange('is missing'));
return if ! $o->{leniently};
}
# Display
my $size = $object->byteLength;
$o->{objects}->{$hashHex} = {needed => $countNeeded, size => $size, dataSize => length $object->data};
$o->report($hashHex, $toStores, $depth, $o->{ui}->bold($o->{ui}->niceFileSize($size)), ' ', $o->{ui}->gray($object->hashesCount, ' hashes'));
# Process all children
foreach my $hash ($object->hashes) {
$o->process($hash, $fromStore, $toStores, $depth + 1) // return;
}
# Write the object to all active stores
for my $toStore (@$toStores) {
next if defined $toStore->{storeError};
next if ! $toStore->{needed}->[$depth];
my $putError = $toStore->{store}->put($hash, $object, $keyPair);
$toStore->{storeError} = $putError if $putError;
}
return 1;
}
sub report {
my $o = shift;
my $hashHex = shift;
my $toStores = shift;
my $depth = shift;
my @text;
for my $toStore (@$toStores) {
if ($toStore->{storeError}) {
push @text, $o->{ui}->red(' ⨯');
} elsif ($toStore->{needed}->[$depth]) {
push @text, $o->{ui}->green(' +');
} else {
push @text, $o->{ui}->green(' ‒');
}
}
push @text, ' ', ' ' x ($depth - 1), $hashHex;
push @text, ' ', @_;
$o->{ui}->line(@text);
}
# BEGIN AUTOGENERATED
package CDS::Commands::UseCache;
sub register {
my $class = shift;
my $cds = shift;
my $help = shift;
my $node000 = CDS::Parser::Node->new(0);
my $node001 = CDS::Parser::Node->new(0);
my $node002 = CDS::Parser::Node->new(0);
my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&useCache});
my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&dropCache});
my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&cache});
$cds->addArrow($node000, 1, 0, 'use');
$cds->addArrow($node002, 1, 0, 'drop');
$cds->addArrow($node006, 1, 0, 'cache');
$help->addArrow($node003, 1, 0, 'cache');
$node000->addArrow($node001, 1, 0, 'cache');
$node001->addArrow($node004, 1, 0, 'STORE', \&collectStore);
return;
}
# A line of text (without word-wrap).
sub line {
my $o = shift;
$o->removeProgress;
my $span = CDS::UI::Span->new(@_);
$o->print($o->{indent});
$span->printTo($o);
$o->print(chr(0x1b), '[0m', "\n");
$o->{hasSpace} = 0;
return;
}
# A line of word-wrapped text.
sub p {
my $o = shift;
$o->removeProgress;
my $span = CDS::UI::Span->new(@_);
$span->wordWrap({lineLength => 0, maxLength => 100 - length $o->{indent}, indent => $o->{indent}});
$o->print($o->{indent});
$span->printTo($o);
$o->print(chr(0x1b), '[0m', "\n");
$o->{hasSpace} = 0;
return;
}
# Line showing the progress.
sub progress {
my $o = shift;
return if $o->{pure};
$| = 1;
$o->{hasProgress} = 1;
my $text = ' '.join('', @_);
$text = substr($text, 0, 79).'…' if length $text > 80;
$text .= ' ' x (80 - length $text) if length $text < 80;
$o->print($text, "\r");
}
# Progress line removal.
sub removeProgress {
my $o = shift;
return if $o->{pure};
return if ! $o->{hasProgress};
$o->print(' ' x 80, "\r");
$o->{hasProgress} = 0;
$| = 0;
}
### Low-level (non-semantic) formatting
sub span {
my $o = shift;
CDS::UI::Span->new(@_) }
sub bold {
my $o = shift;
my $span = CDS::UI::Span->new(@_);
$span->{bold} = 1;
return $span;
}
sub underlined {
my $o = shift;
my $span = CDS::UI::Span->new(@_);
$span->{underlined} = 1;
return $span;
}
sub foreground {
my $o = shift;
my $foreground = shift;
my $span = CDS::UI::Span->new(@_);
$span->{foreground} = $foreground;
return $span;
}
sub background {
my $o = shift;
my $background = shift;
my $span = CDS::UI::Span->new(@_);
$span->{background} = $background;
return $span;
}
sub red {
my $o = shift;
$o->foreground(196, @_) } # for failure
sub green {
my $o = shift;
$o->foreground(40, @_) } # for success
sub orange {
my $o = shift;
$o->foreground(166, @_) } # for warnings
sub blue {
my $o = shift;
$o->foreground(33, @_) } # to highlight something (selection)
sub violet {
my $o = shift;
$o->foreground(93, @_) } # to highlight something (selection)
sub gold {
my $o = shift;
$o->foreground(238, @_) } # for commands that can be executed
sub gray {
my $o = shift;
$o->foreground(246, @_) } # for additional (less important) information
sub darkBold {
my $o = shift;
my $span = CDS::UI::Span->new(@_);
$span->{bold} = 1;
$span->{foreground} = 240;
return $span;
}
### Semantic output
sub title {
my $o = shift;
$o->line($o->bold(@_)) }
sub left {
my $o = shift;
my $width = shift;
my $text = shift;
return substr($text, 0, $width - 1).'…' if length $text > $width;
return $text . ' ' x ($width - length $text);
}
sub right {
my $o = shift;
my $width = shift;
my $text = shift;
return substr($text, 0, $width - 1).'…' if length $text > $width;
return ' ' x ($width - length $text) . $text;
}
sub keyValue {
my $o = shift;
my $key = shift;
my $firstLine = shift;
my $indent = $o->{valueIndent} - length $o->{indent};
$key = substr($key, 0, $indent - 2).'…' if defined $firstLine && length $key >= $indent;
$key .= ' ' x ($indent - length $key);
$o->line($o->gray($key), $firstLine);
my $noKey = ' ' x $indent;
for my $line (@_) { $o->line($noKey, $line); }
return;
}
sub command {
my $o = shift;
$o->line($o->bold(@_)) }
sub verbose {
my $o = shift;
$o->line($o->foreground(45, @_)) if $o->{verbose} }
sub pGreen {
my $o = shift;
$o->p($o->green(@_));
return;
}
sub pOrange {
my $o = shift;
$o->p($o->orange(@_));
return;
}
sub pRed {
my $o = shift;
$o->p($o->red(@_));
return;
}
### Warnings and errors
sub hasWarning { shift->{hasWarning} }
sub hasError { shift->{hasError} }
sub warning {
my $o = shift;
$o->{hasWarning} = 1;
$o->p($o->orange(@_));
return;
}
sub error {
my $o = shift;
$o->{hasError} = 1;
my $span = CDS::UI::Span->new(@_);
$span->{background} = 196;
$span->{foreground} = 15;
$span->{bold} = 1;
$o->line($span);
return;
}
### Semantic formatting
sub a {
my $o = shift;
$o->underlined(@_) }
### Human readable formats
sub niceBytes {
my $o = shift;
my $bytes = shift;
my $maxLength = shift;
my $length = length $bytes;
my $text = defined $maxLength && $length > $maxLength ? substr($bytes, 0, $maxLength - 1).'…' : $bytes;
$text =~ s/[\x00-\x1f\x7f-\xff]/./g;
return $text;
}
sub niceFileSize {
my $o = shift;
my $fileSize = shift;
return $fileSize.' bytes' if $fileSize < 1000;
return sprintf('%0.1f', $fileSize / 1000).' KB' if $fileSize < 10000;
return sprintf('%0.0f', $fileSize / 1000).' KB' if $fileSize < 1000000;
return sprintf('%0.1f', $fileSize / 1000000).' MB' if $fileSize < 10000000;
return sprintf('%0.0f', $fileSize / 1000000).' MB' if $fileSize < 1000000000;
return sprintf('%0.1f', $fileSize / 1000000000).' GB' if $fileSize < 10000000000;
return sprintf('%0.0f', $fileSize / 1000000000).' GB';
}
sub niceDateTimeLocal {
my $o = shift;
my $time = shift // time() * 1000;
my @t = localtime($time / 1000);
return sprintf('%04d-%02d-%02d %02d:%02d:%02d', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]);
}
sub niceDateTime {
my $o = shift;
my $time = shift // time() * 1000;
my @t = gmtime($time / 1000);
return sprintf('%04d-%02d-%02d %02d:%02d:%02d UTC', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]);
}
sub niceDate {
my $o = shift;
my $time = shift // time() * 1000;
my @t = gmtime($time / 1000);
return sprintf('%04d-%02d-%02d', $t[5] + 1900, $t[4] + 1, $t[3]);
}
sub niceTime {
my $o = shift;
my $time = shift // time() * 1000;
my @t = gmtime($time / 1000);
return sprintf('%02d:%02d:%02d UTC', $t[2], $t[1], $t[0]);
}
### Special output
sub record {
my $o = shift;
my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
my $storeUrl = shift;
CDS::UI::Record->display($o, $record, $storeUrl) }
sub recordChildren {
my $o = shift;
my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
my $storeUrl = shift;
for my $child ($record->children) {
CDS::UI::Record->display($o, $child, $storeUrl);
}
}
sub selector {
my $o = shift;
my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
my $rootLabel = shift;
my $item = $selector->document->get($selector);
my $revision = $item->{revision} ? $o->green(' ', $o->niceDateTime($item->{revision})) : '';
if ($selector->{id} eq 'ROOT') {
$o->line($o->bold($rootLabel // 'Data tree'), $revision);
$o->recordChildren($selector->record);
$o->selectorChildren($selector);
} else {
my $label = $selector->label;
my $labelText = length $label > 64 ? substr($label, 0, 64).'…' : $label;
$labelText =~ s/[\x00-\x1f\x7f-\xff]/·/g;
$o->line($o->blue($labelText), $revision);
$o->pushIndent;
$o->recordChildren($selector->record);
$o->selectorChildren($selector);
$o->popIndent;
}
}
sub selectorChildren {
my $o = shift;
my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
for my $child (sort { $a->{id} cmp $b->{id} } $selector->children) {
$o->selector($child);
}
}
sub hexDump {
my $o = shift;
my $bytes = shift;
CDS::UI::HexDump->new($o, $bytes) }
package CDS::UI::HexDump;
sub new {
my $class = shift;
my $ui = shift;
my $bytes = shift;
return bless {ui => $ui, bytes => $bytes, styleChanges => [], };
}
sub reset { chr(0x1b).'[0m' }
sub foreground {
my $o = shift;
my $color = shift;
chr(0x1b).'[0;38;5;'.$color.'m' }
sub changeStyle {
my $o = shift;
push @{$o->{styleChanges}}, @_;
}
sub styleHashList {
my $o = shift;
my $offset = shift;
my $hashesCount = unpack('L>', substr($o->{bytes}, $offset, 4));
my $dataStart = $offset + 4 + $hashesCount * 32;
return $offset if $dataStart > length $o->{bytes};
# Styles
my $length = length $bytes;
my $text = $length > 64 ? substr($bytes, 0, 64).'…' : $bytes;
$text =~ s/[\x00-\x1f\x7f-\xff]/·/g;
my @value = ($text);
if ($length <= 8) {
my $integer = CDS->integerFromBytes($bytes);
push @value, $o->{ui}->gray(' = ', $integer, $o->looksLikeTimestamp($integer) ? ' = '.$o->{ui}->niceDateTime($integer).' = '.$o->{ui}->niceDateTimeLocal($integer) : '');
}
push @value, $o->{ui}->gray(' = ', CDS->floatFromBytes($bytes)) if $length == 4 || $length == 8;
push @value, $o->{ui}->gray(' = ', CDS::Hash->fromBytes($bytes)->hex) if $length == 32;
push @value, $o->{ui}->gray(' (', length $bytes, ' bytes)') if length $bytes > 64;
return @value;
}
sub dateValue {
my $o = shift;
my $bytes = shift;
my $integer = CDS->integerFromBytes($bytes);
return $integer if ! $o->looksLikeTimestamp($integer);
return $o->{ui}->niceDateTime($integer), ' ', $o->{ui}->gray($o->{ui}->niceDateTimeLocal($integer));
}
sub revisionValue {
my $o = shift;
my $bytes = shift;
my $integer = CDS->integerFromBytes($bytes);
return $integer if ! $o->looksLikeTimestamp($integer);
return $o->{ui}->niceDateTime($integer);
}
sub looksLikeTimestamp {
my $o = shift;
my $integer = shift;
return $integer > 100000000000 && $integer < 10000000000000;
}
package CDS::UI::Span;
sub new {
my $class = shift;
return bless {
text => [@_],
};
}
sub printTo {
my $o = shift;
my $ui = shift;
my $parent = shift;
if ($parent) {
$o->{appliedForeground} = $o->{foreground} // $parent->{appliedForeground};
$o->{appliedBackground} = $o->{background} // $parent->{appliedBackground};
$o->{appliedBold} = $o->{bold} // $parent->{appliedBold} // 0;
$o->{appliedUnderlined} = $o->{underlined} // $parent->{appliedUnderlined} // 0;
} else {
$o->{appliedForeground} = $o->{foreground};
$o->{appliedBackground} = $o->{background};
$o->{appliedBold} = $o->{bold} // 0;
$o->{appliedUnderlined} = $o->{underlined} // 0;
}
my $style = chr(0x1b).'[0';
$style .= ';1' if $o->{appliedBold};
$style .= ';4' if $o->{appliedUnderlined};
$style .= ';38;5;'.$o->{appliedForeground} if defined $o->{appliedForeground};
$style .= ';48;5;'.$o->{appliedBackground} if defined $o->{appliedBackground};
$style .= 'm';
my $needStyle = 1;
for my $child (@{$o->{text}}) {
my $ref = ref $child;
if ($ref eq 'CDS::UI::Span') {
$child->printTo($ui, $o);
$needStyle = 1;
next;
} elsif (length $ref) {
warn 'Printing REF';
$child = $ref;
} elsif (! defined $child) {
warn 'Printing UNDEF';
$child = 'UNDEF';
}
if ($needStyle) {
$ui->print($style);
$needStyle = 0;
}
$ui->print($child);
}
}
sub wordWrap {
my $o = shift;
my $state = shift;
my $index = -1;
for my $child (@{$o->{text}}) {
$index += 1;
next if ! defined $child;
my $ref = ref $child;
if ($ref eq 'CDS::UI::Span') {
$child->wordWrap($state);
next;
} elsif (length $ref) {
warn 'Printing REF';
$child = $ref;
} elsif (! defined $child) {
warn 'Printing UNDEF';
$child = 'UNDEF';
}
my $position = -1;
for my $char (split //, $child) {
$position += 1;
$state->{lineLength} += 1;
( run in 2.675 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )