Welcome to TiddlyWiki created by Jeremy Ruston, Copyright © 2007 UnaMesa Association
/***
|Name|CalendarPlugin|
|Source|http://www.TiddlyTools.com/#CalendarPlugin|
|Version|1.5.0|
|Author|Eric Shulman|
|Original Author|SteveRumsby|
|License|unknown|
|~CoreVersion|2.1|
|Type|plugin|
|Requires||
|Overrides||
|Options|##Configuration|
|Description|display monthly and yearly calendars|
NOTE: For //enhanced// date popup display, optionally install [[DatePlugin]] and [[ReminderMacros]]
!!!Usage:
<<<
|{{{<<calendar>>}}}|full-year calendar for the current year|
|{{{<<calendar year>>}}}|full-year calendar for the specified year|
|{{{<<calendar year month>>}}}|one month calendar for the specified month and year|
|{{{<<calendar thismonth>>}}}|one month calendar for the current month|
|{{{<<calendar lastmonth>>}}}|one month calendar for last month|
|{{{<<calendar nextmonth>>}}}|one month calendar for next month|
|{{{<<calendar +n>>}}}<br>{{{<<calendar -n>>}}}|one month calendar for a month +/- 'n' months from now|
<<<
!!!Configuration:
<<<
|''First day of week:''<br>{{{config.options.txtCalFirstDay}}}|<<option txtCalFirstDay>>|(Monday = 0, Sunday = 6)|
|''First day of weekend:''<br>{{{config.options.txtCalStartOfWeekend}}}|<<option txtCalStartOfWeekend>>|(Monday = 0, Sunday = 6)|
<<option chkDisplayWeekNumbers>> Display week numbers //(note: Monday will be used as the start of the week)//
|''Week number display format:''<br>{{{config.options.txtWeekNumberDisplayFormat }}}|<<option txtWeekNumberDisplayFormat >>|
|''Week number link format:''<br>{{{config.options.txtWeekNumberLinkFormat }}}|<<option txtWeekNumberLinkFormat >>|
<<<
!!!Revisions
<<<
2009.04.31 [1.5.0] rewrote onClickCalendarDate() (popup handler) and added config.options.txtCalendarReminderTags. Partial code reduction/cleanup. Assigned true version number (1.5.0)
2008.09.10 added '+n' (and '-n') param to permit display of relative months (e.g., '+6' means 'six months from now', '-3' means 'three months ago'. Based on suggestion from Jean.
2008.06.17 added support for config.macros.calendar.todaybg
2008.02.27 in handler(), DON'T set hard-coded default date format, so that *customized* value (pre-defined in config.macros.calendar.journalDateFmt is used.
2008.02.17 in createCalendarYear(), fix next/previous year calculation (use parseInt() to convert to numeric value). Also, use journalDateFmt for date linking when NOT using [[DatePlugin]].
2008.02.16 in createCalendarDay(), week numbers now created as TiddlyLinks, allowing quick creation/navigation to 'weekly' journals (based on request from Kashgarinn)
2008.01.08 in createCalendarMonthHeader(), 'month year' heading is now created as TiddlyLink, allowing quick creation/navigation to 'month-at-a-time' journals
2007.11.30 added 'return false' to onclick handlers (prevent IE from opening blank pages)
2006.08.23 added handling for weeknumbers (code supplied by Martin Budden (see 'wn**' comment marks). Also, incorporated updated by Jeremy Sheeley to add caching for reminders (see [[ReminderMacros]], if installed)
2005.10.30 in config.macros.calendar.handler(), use 'tbody' element for IE compatibility. Also, fix year calculation for IE's getYear() function (which returns '2005' instead of '105'). Also, in createCalendarDays(), use showDate() function (see [[DatePlugin]], if installed) to render autostyled date with linked popup. Updated calendar stylesheet definition: use .calendar class-specific selectors, add text centering and margin settings
2006.05.29 added journalDateFmt handling
<<<
!!!Code
***/
//{{{
version.extensions.CalendarPlugin= { major: 1, minor: 5, revision: 0, date: new Date(2009,5,31)};
//}}}
//{{{
if(config.options.txtCalFirstDay == undefined)
config.options.txtCalFirstDay = 0;
if(config.options.txtCalStartOfWeekend == undefined)
config.options.txtCalStartOfWeekend = 5;
if(config.options.chkDisplayWeekNumbers == undefined)
config.options.chkDisplayWeekNumbers = false;
if(config.options.chkDisplayWeekNumbers)
config.options.txtCalFirstDay = 0;
if(config.options.txtWeekNumberDisplayFormat == undefined)
config.options.txtWeekNumberDisplayFormat = 'w0WW';
if(config.options.txtWeekNumberLinkFormat == undefined)
config.options.txtWeekNumberLinkFormat = 'YYYY-w0WW';
if(config.options.txtCalendarReminderTags == undefined)
config.options.txtCalendarReminderTags = 'reminder';
config.macros.calendar = {
monthnames:['Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'],
daynames:['M','T','W','T','F','S','S'],
todaybg:'#ccccff',
weekendbg:'#c0c0c0',
monthbg:'#e0e0e0',
holidaybg:'#ffc0c0',
journalDateFmt:'DD MMM YYYY',
monthdays:[31,28,31,30,31,30,31,31,30,31,30,31],
holidays:[ ] // for customization see [[CalendarPluginConfig]]
};
//}}}
//{{{
function calendarIsHoliday(date)
{
var longHoliday = date.formatString('0DD/0MM/YYYY');
var shortHoliday = date.formatString('0DD/0MM');
for(var i = 0; i < config.macros.calendar.holidays.length; i++) {
if( config.macros.calendar.holidays[i]==longHoliday
|| config.macros.calendar.holidays[i]==shortHoliday)
return true;
}
return false;
}
//}}}
//{{{
config.macros.calendar.handler = function(place,macroName,params) {
var calendar = createTiddlyElement(place, 'table', null, 'calendar', null);
var tbody = createTiddlyElement(calendar, 'tbody');
var today = new Date();
var year = today.getYear();
if (year<1900) year+=1900;
// get journal format from SideBarOptions (ELS 5/29/06 - suggested by MartinBudden)
var text = store.getTiddlerText('SideBarOptions');
var re = new RegExp('<<(?:newJournal)([^>]*)>>','mg'); var fm = re.exec(text);
if (fm && fm[1]!=null) { var pa=fm[1].readMacroParams(); if (pa[0]) this.journalDateFmt = pa[0]; }
var month=-1;
if (params[0] == 'thismonth') {
var month=today.getMonth();
} else if (params[0] == 'lastmonth') {
var month = today.getMonth()-1; if (month==-1) { month=11; year--; }
} else if (params[0] == 'nextmonth') {
var month = today.getMonth()+1; if (month>11) { month=0; year++; }
} else if (params[0]&&'+-'.indexOf(params[0].substr(0,1))!=-1) {
var month = today.getMonth()+parseInt(params[0]);
if (month>11) { year+=Math.floor(month/12); month%=12; };
if (month<0) { year+=Math.floor(month/12); month=12+month%12; }
} else if (params[0]) {
year = params[0];
if(params[1]) month=parseInt(params[1])-1;
if (month>11) month=11; if (month<0) month=0;
}
if (month!=-1) {
cacheReminders(new Date(year, month, 1, 0, 0), 31);
createCalendarOneMonth(tbody, year, month);
} else {
cacheReminders(new Date(year, 0, 1, 0, 0), 366);
createCalendarYear(tbody, year);
}
window.reminderCacheForCalendar = null;
}
//}}}
//{{{
// cache used to store reminders while the calendar is being rendered
// it will be renulled after the calendar is fully rendered.
window.reminderCacheForCalendar = null;
//}}}
//{{{
function cacheReminders(date, leadtime)
{
if (window.findTiddlersWithReminders == null) return;
window.reminderCacheForCalendar = {};
var leadtimeHash = [];
leadtimeHash [0] = 0;
leadtimeHash [1] = leadtime;
var t = findTiddlersWithReminders(date, leadtimeHash, null, 1);
for(var i = 0; i < t.length; i++) {
//just tag it in the cache, so that when we're drawing days, we can bold this one.
window.reminderCacheForCalendar[t[i]['matchedDate']] = 'reminder:' + t[i]['params']['title'];
}
}
//}}}
//{{{
function createCalendarOneMonth(calendar, year, mon)
{
var row = createTiddlyElement(calendar, 'tr');
createCalendarMonthHeader(calendar, row, config.macros.calendar.monthnames[mon]+' '+year, true, year, mon);
row = createTiddlyElement(calendar, 'tr');
createCalendarDayHeader(row, 1);
createCalendarDayRowsSingle(calendar, year, mon);
}
//}}}
//{{{
function createCalendarMonth(calendar, year, mon)
{
var row = createTiddlyElement(calendar, 'tr');
createCalendarMonthHeader(calendar, row, config.macros.calendar.monthnames[mon]+' '+ year, false, year, mon);
row = createTiddlyElement(calendar, 'tr');
createCalendarDayHeader(row, 1);
createCalendarDayRowsSingle(calendar, year, mon);
}
//}}}
//{{{
function createCalendarYear(calendar, year)
{
var row;
row = createTiddlyElement(calendar, 'tr');
var back = createTiddlyElement(row, 'td');
var backHandler = function() {
removeChildren(calendar);
createCalendarYear(calendar, parseInt(year)-1);
return false; // consume click
};
createTiddlyButton(back, '<', 'Previous year', backHandler);
back.align = 'center';
var yearHeader = createTiddlyElement(row, 'td', null, 'calendarYear', year);
yearHeader.align = 'center';
yearHeader.setAttribute('colSpan',config.options.chkDisplayWeekNumbers?22:19);//wn**
var fwd = createTiddlyElement(row, 'td');
var fwdHandler = function() {
removeChildren(calendar);
createCalendarYear(calendar, parseInt(year)+1);
return false; // consume click
};
createTiddlyButton(fwd, '>', 'Next year', fwdHandler);
fwd.align = 'center';
createCalendarMonthRow(calendar, year, 0);
createCalendarMonthRow(calendar, year, 3);
createCalendarMonthRow(calendar, year, 6);
createCalendarMonthRow(calendar, year, 9);
}
//}}}
//{{{
function createCalendarMonthRow(cal, year, mon)
{
var row = createTiddlyElement(cal, 'tr');
createCalendarMonthHeader(cal, row, config.macros.calendar.monthnames[mon], false, year, mon);
createCalendarMonthHeader(cal, row, config.macros.calendar.monthnames[mon+1], false, year, mon);
createCalendarMonthHeader(cal, row, config.macros.calendar.monthnames[mon+2], false, year, mon);
row = createTiddlyElement(cal, 'tr');
createCalendarDayHeader(row, 3);
createCalendarDayRows(cal, year, mon);
}
//}}}
//{{{
function createCalendarMonthHeader(cal, row, name, nav, year, mon)
{
var month;
if (nav) {
var back = createTiddlyElement(row, 'td');
back.align = 'center';
back.style.background = config.macros.calendar.monthbg;
var backMonHandler = function() {
var newyear = year;
var newmon = mon-1;
if(newmon == -1) { newmon = 11; newyear = newyear-1;}
removeChildren(cal);
cacheReminders(new Date(newyear, newmon , 1, 0, 0), 31);
createCalendarOneMonth(cal, newyear, newmon);
return false; // consume click
};
createTiddlyButton(back, '<', 'Previous month', backMonHandler);
month = createTiddlyElement(row, 'td', null, 'calendarMonthname')
createTiddlyLink(month,name,true);
month.setAttribute('colSpan', config.options.chkDisplayWeekNumbers?6:5);//wn**
var fwd = createTiddlyElement(row, 'td');
fwd.align = 'center';
fwd.style.background = config.macros.calendar.monthbg;
var fwdMonHandler = function() {
var newyear = year;
var newmon = mon+1;
if(newmon == 12) { newmon = 0; newyear = newyear+1;}
removeChildren(cal);
cacheReminders(new Date(newyear, newmon , 1, 0, 0), 31);
createCalendarOneMonth(cal, newyear, newmon);
return false; // consume click
};
createTiddlyButton(fwd, '>', 'Next month', fwdMonHandler);
} else {
month = createTiddlyElement(row, 'td', null, 'calendarMonthname', name)
month.setAttribute('colSpan',config.options.chkDisplayWeekNumbers?8:7);//wn**
}
month.align = 'center';
month.style.background = config.macros.calendar.monthbg;
}
//}}}
//{{{
function createCalendarDayHeader(row, num)
{
var cell;
for(var i = 0; i < num; i++) {
if (config.options.chkDisplayWeekNumbers) createTiddlyElement(row, 'td');//wn**
for(var j = 0; j < 7; j++) {
var d = j + (config.options.txtCalFirstDay - 0);
if(d > 6) d = d - 7;
cell = createTiddlyElement(row, 'td', null, null, config.macros.calendar.daynames[d]);
if(d == (config.options.txtCalStartOfWeekend-0) || d == (config.options.txtCalStartOfWeekend-0+1))
cell.style.background = config.macros.calendar.weekendbg;
}
}
}
//}}}
//{{{
function createCalendarDays(row, col, first, max, year, mon) {
var i;
if (config.options.chkDisplayWeekNumbers){
if (first<=max) {
var ww = new Date(year,mon,first);
var td=createTiddlyElement(row, 'td');//wn**
var link=createTiddlyLink(td,ww.formatString(config.options.txtWeekNumberLinkFormat),false);
link.appendChild(document.createTextNode(
ww.formatString(config.options.txtWeekNumberDisplayFormat)));
}
else createTiddlyElement(row, 'td');//wn**
}
for(i = 0; i < col; i++)
createTiddlyElement(row, 'td');
var day = first;
for(i = col; i < 7; i++) {
var d = i + (config.options.txtCalFirstDay - 0);
if(d > 6) d = d - 7;
var daycell = createTiddlyElement(row, 'td');
var isaWeekend=((d==(config.options.txtCalStartOfWeekend-0)
|| d==(config.options.txtCalStartOfWeekend-0+1))?true:false);
if(day > 0 && day <= max) {
var celldate = new Date(year, mon, day);
// ELS 10/30/05 - use <<date>> macro's showDate() function to create popup
// ELS 05/29/06 - use journalDateFmt
if (window.showDate) showDate(daycell,celldate,'popup','DD',
config.macros.calendar.journalDateFmt,true, isaWeekend);
else {
if(isaWeekend) daycell.style.background = config.macros.calendar.weekendbg;
var title = celldate.formatString(config.macros.calendar.journalDateFmt);
if(calendarIsHoliday(celldate))
daycell.style.background = config.macros.calendar.holidaybg;
var now=new Date();
if ((now-celldate>=0) && (now-celldate<86400000)) // is today?
daycell.style.background = config.macros.calendar.todaybg;
if(window.findTiddlersWithReminders == null) {
var link = createTiddlyLink(daycell, title, false);
link.appendChild(document.createTextNode(day));
} else
var button = createTiddlyButton(daycell, day, title, onClickCalendarDate);
}
}
day++;
}
}
//}}}
//{{{
// Create a pop-up containing:
// * a link to a tiddler for this date
// * a 'new tiddler' link to add a reminder for this date
// * links to current reminders for this date
// NOTE: this code is only used if [[ReminderMacros]] is installed AND [[DatePlugin]] is //not// installed.
function onClickCalendarDate(ev) { ev=ev||window.event;
var d=new Date(this.getAttribute('title')); var date=d.formatString(config.macros.calendar.journalDateFmt);
var p=Popup.create(this); if (!p) return;
createTiddlyLink(createTiddlyElement(p,'li'),date,true);
var rem='\\n\\<\\<reminder day:%0 month:%1 year:%2 title: \\>\\>';
rem=rem.format([d.getDate(),d.getMonth()+1,d.getYear()+1900]);
var cmd="<<newTiddler label:[[new reminder...]] prompt:[[add a new reminder to '%0']]"
+" title:[[%0]] text:{{store.getTiddlerText('%0','')+'%1'}} tag:%2>>";
wikify(cmd.format([date,rem,config.options.txtCalendarReminderTags]),p);
createTiddlyElement(p,'hr');
var t=findTiddlersWithReminders(d,[0,31],null,1);
for(var i=0; i<t.length; i++) {
var link=createTiddlyLink(createTiddlyElement(p,'li'), t[i].tiddler, false);
link.appendChild(document.createTextNode(t[i]['params']['title']));
}
Popup.show(); ev.cancelBubble=true; if (ev.stopPropagation) ev.stopPropagation(); return false;
}
//}}}
//{{{
function calendarMaxDays(year, mon)
{
var max = config.macros.calendar.monthdays[mon];
if(mon == 1 && (year % 4) == 0 && ((year % 100) != 0 || (year % 400) == 0)) max++;
return max;
}
//}}}
//{{{
function createCalendarDayRows(cal, year, mon)
{
var row = createTiddlyElement(cal, 'tr');
var first1 = (new Date(year, mon, 1)).getDay() -1 - (config.options.txtCalFirstDay-0);
if(first1 < 0) first1 = first1 + 7;
var day1 = -first1 + 1;
var first2 = (new Date(year, mon+1, 1)).getDay() -1 - (config.options.txtCalFirstDay-0);
if(first2 < 0) first2 = first2 + 7;
var day2 = -first2 + 1;
var first3 = (new Date(year, mon+2, 1)).getDay() -1 - (config.options.txtCalFirstDay-0);
if(first3 < 0) first3 = first3 + 7;
var day3 = -first3 + 1;
var max1 = calendarMaxDays(year, mon);
var max2 = calendarMaxDays(year, mon+1);
var max3 = calendarMaxDays(year, mon+2);
while(day1 <= max1 || day2 <= max2 || day3 <= max3) {
row = createTiddlyElement(cal, 'tr');
createCalendarDays(row, 0, day1, max1, year, mon); day1 += 7;
createCalendarDays(row, 0, day2, max2, year, mon+1); day2 += 7;
createCalendarDays(row, 0, day3, max3, year, mon+2); day3 += 7;
}
}
//}}}
//{{{
function createCalendarDayRowsSingle(cal, year, mon)
{
var row = createTiddlyElement(cal, 'tr');
var first1 = (new Date(year, mon, 1)).getDay() -1 - (config.options.txtCalFirstDay-0);
if(first1 < 0) first1 = first1+ 7;
var day1 = -first1 + 1;
var max1 = calendarMaxDays(year, mon);
while(day1 <= max1) {
row = createTiddlyElement(cal, 'tr');
createCalendarDays(row, 0, day1, max1, year, mon); day1 += 7;
}
}
//}}}
//{{{
setStylesheet('.calendar, .calendar table, .calendar th, .calendar tr, .calendar td { text-align:center; } .calendar, .calendar a { margin:0px !important; padding:0px !important; }', 'calendarStyles');
//}}}
/***
|Name|CheckboxPlugin|
|Source|http://www.TiddlyTools.com/#CheckboxPlugin|
|Documentation|http://www.TiddlyTools.com/#CheckboxPluginInfo|
|Version|2.4.0|
|Author|Eric Shulman - ELS Design Studios|
|License|http://www.TiddlyTools.com/#LegalStatements <br>and [[Creative Commons Attribution-ShareAlike 2.5 License|http://creativecommons.org/licenses/by-sa/2.5/]]|
|~CoreVersion|2.1|
|Type|plugin|
|Requires||
|Overrides||
|Description|Add checkboxes to your tiddler content|
This plugin extends the TiddlyWiki syntax to allow definition of checkboxes that can be embedded directly in tiddler content. Checkbox states are preserved by:
* by setting/removing tags on specified tiddlers,
* or, by setting custom field values on specified tiddlers,
* or, by saving to a locally-stored cookie ID,
* or, automatically modifying the tiddler content (deprecated)
When an ID is assigned to the checkbox, it enables direct programmatic access to the checkbox DOM element, as well as creating an entry in TiddlyWiki's config.options[ID] internal data. In addition to tracking the checkbox state, you can also specify custom javascript for programmatic initialization and onClick event handling for any checkbox, so you can provide specialized side-effects in response to state changes.
!!!!!Documentation
>see [[CheckboxPluginInfo]]
!!!!!Revisions
<<<
2008.01.08 [*.*.*] plugin size reduction: documentation moved to [[CheckboxPluginInfo]]
2008.01.05 [2.4.0] set global "window.place" to current checkbox element when processing checkbox clicks. This allows init/beforeClick/afterClick handlers to reference RELATIVE elements, including using "story.findContainingTiddler(place)". Also, wrap handlers in "function()" so "return" can be used within handler code.
|please see [[CheckboxPluginInfo]] for additional revision details|
2005.12.07 [0.9.0] initial BETA release
<<<
!!!!!Code
***/
//{{{
version.extensions.CheckboxPlugin = {major: 2, minor: 4, revision:0 , date: new Date(2008,1,5)};
//}}}
//{{{
config.checkbox = { refresh: { tagged:true, tagging:true, container:true } };
config.formatters.push( {
name: "checkbox",
match: "\\[[xX_ ][\\]\\=\\(\\{]",
lookahead: "\\[([xX_ ])(=[^\\s\\(\\]{]+)?(\\([^\\)]*\\))?({[^}]*})?({[^}]*})?({[^}]*})?\\]",
handler: function(w) {
var lookaheadRegExp = new RegExp(this.lookahead,"mg");
lookaheadRegExp.lastIndex = w.matchStart;
var lookaheadMatch = lookaheadRegExp.exec(w.source)
if(lookaheadMatch && lookaheadMatch.index == w.matchStart) {
// get params
var checked=(lookaheadMatch[1].toUpperCase()=="X");
var id=lookaheadMatch[2];
var target=lookaheadMatch[3];
if (target) target=target.substr(1,target.length-2).trim(); // trim off parentheses
var fn_init=lookaheadMatch[4];
var fn_clickBefore=lookaheadMatch[5];
var fn_clickAfter=lookaheadMatch[6];
var tid=story.findContainingTiddler(w.output); if (tid) tid=tid.getAttribute("tiddler");
var srctid=w.tiddler?w.tiddler.title:null;
config.macros.checkbox.create(w.output,tid,srctid,w.matchStart+1,checked,id,target,config.checkbox.refresh,fn_init,fn_clickBefore,fn_clickAfter);
w.nextMatch = lookaheadMatch.index + lookaheadMatch[0].length;
}
}
} );
config.macros.checkbox = {
handler: function(place,macroName,params,wikifier,paramString,tiddler) {
if(!(tiddler instanceof Tiddler)) { // if no tiddler passed in try to find one
var here=story.findContainingTiddler(place);
if (here) tiddler=store.getTiddler(here.getAttribute("tiddler"))
}
var srcpos=0; // "inline X" not applicable to macro syntax
var target=params.shift(); if (!target) target="";
var defaultState=params[0]=="checked"; if (defaultState) params.shift();
var id=params.shift(); if (id && !id.length) id=null;
var fn_init=params.shift(); if (fn_init && !fn_init.length) fn_init=null;
var fn_clickBefore=params.shift();
if (fn_clickBefore && !fn_clickBefore.length) fn_clickBefore=null;
var fn_clickAfter=params.shift();
if (fn_clickAfter && !fn_clickAfter.length) fn_clickAfter=null;
var refresh={ tagged:true, tagging:true, container:false };
this.create(place,tiddler.title,tiddler.title,0,defaultState,id,target,refresh,fn_init,fn_clickBefore,fn_clickAfter);
},
create: function(place,tid,srctid,srcpos,defaultState,id,target,refresh,fn_init,fn_clickBefore,fn_clickAfter) {
// create checkbox element
var c = document.createElement("input");
c.setAttribute("type","checkbox");
c.onclick=this.onClickCheckbox;
c.srctid=srctid; // remember source tiddler
c.srcpos=srcpos; // remember location of "X"
c.container=tid; // containing tiddler (may be null if not in a tiddler)
c.tiddler=tid; // default target tiddler
c.refresh = {};
c.refresh.container = refresh.container;
c.refresh.tagged = refresh.tagged;
c.refresh.tagging = refresh.tagging;
place.appendChild(c);
// set default state
c.checked=defaultState;
// track state in config.options.ID
if (id) {
c.id=id.substr(1); // trim off leading "="
if (config.options[c.id]!=undefined)
c.checked=config.options[c.id];
else
config.options[c.id]=c.checked;
}
// track state in (tiddlername|tagname) or (fieldname@tiddlername)
if (target) {
var pos=target.indexOf("@");
if (pos!=-1) {
c.field=pos?target.substr(0,pos):"checked"; // get fieldname (or use default "checked")
c.tiddler=target.substr(pos+1); // get specified tiddler name (if any)
if (!c.tiddler || !c.tiddler.length) c.tiddler=tid; // if tiddler not specified, default == container
if (store.getValue(c.tiddler,c.field)!=undefined)
c.checked=(store.getValue(c.tiddler,c.field)=="true"); // set checkbox from saved state
} else {
var pos=target.indexOf("|"); if (pos==-1) var pos=target.indexOf(":");
c.tag=target;
if (pos==0) c.tag=target.substr(1); // trim leading "|" or ":"
if (pos>0) { c.tiddler=target.substr(0,pos); c.tag=target.substr(pos+1); }
if (!c.tag.length) c.tag="checked";
var t=store.getTiddler(c.tiddler);
if (t && t.tags)
c.checked=t.isTagged(c.tag); // set checkbox from saved state
}
}
// trim off surrounding { and } delimiters from init/click handlers
if (fn_init) c.fn_init="(function(){"+fn_init.trim().substr(1,fn_init.length-2)+"})()";
if (fn_clickBefore) c.fn_clickBefore="(function(){"+fn_clickBefore.trim().substr(1,fn_clickBefore.length-2)+"})()";
if (fn_clickAfter) c.fn_clickAfter="(function(){"+fn_clickAfter.trim().substr(1,fn_clickAfter.length-2)+"})()";
c.init=true; c.onclick(); c.init=false; // compute initial state and save in tiddler/config/cookie
},
onClickCheckbox: function(event) {
window.place=this;
if (this.init && this.fn_init) // custom function hook to set initial state (run only once)
{ try { eval(this.fn_init); } catch(e) { displayMessage("Checkbox init error: "+e.toString()); } }
if (!this.init && this.fn_clickBefore) // custom function hook to override changes in checkbox state
{ try { eval(this.fn_clickBefore) } catch(e) { displayMessage("Checkbox onClickBefore error: "+e.toString()); } }
if (this.id)
// save state in config AND cookie (only when ID starts with 'chk')
{ config.options[this.id]=this.checked; if (this.id.substr(0,3)=="chk") saveOptionCookie(this.id); }
if (this.srctid && this.srcpos>0 && (!this.id || this.id.substr(0,3)!="chk") && !this.tag && !this.field) {
// save state in tiddler content only if not using cookie, tag or field tracking
var t=store.getTiddler(this.srctid); // put X in original source tiddler (if any)
if (t && this.checked!=(t.text.substr(this.srcpos,1).toUpperCase()=="X")) { // if changed
t.set(null,t.text.substr(0,this.srcpos)+(this.checked?"X":"_")+t.text.substr(this.srcpos+1),null,null,t.tags);
if (!story.isDirty(t.title)) story.refreshTiddler(t.title,null,true);
store.setDirty(true);
}
}
if (this.field) {
if (this.checked && !store.tiddlerExists(this.tiddler))
store.saveTiddler(this.tiddler,this.tiddler,"",config.options.txtUserName,new Date());
// set the field value in the target tiddler
store.setValue(this.tiddler,this.field,this.checked?"true":"false");
// DEBUG: displayMessage(this.field+"@"+this.tiddler+" is "+this.checked);
}
if (this.tag) {
if (this.checked && !store.tiddlerExists(this.tiddler))
store.saveTiddler(this.tiddler,this.tiddler,"",config.options.txtUserName,new Date());
var t=store.getTiddler(this.tiddler);
if (t) {
var tagged=(t.tags && t.tags.indexOf(this.tag)!=-1);
if (this.checked && !tagged) { t.tags.push(this.tag); store.setDirty(true); }
if (!this.checked && tagged) { t.tags.splice(t.tags.indexOf(this.tag),1); store.setDirty(true); }
}
// if tag state has been changed, update display of corresponding tiddlers (unless they are in edit mode...)
if (this.checked!=tagged) {
if (this.refresh.tagged) {
if (!story.isDirty(this.tiddler)) // the TAGGED tiddler in view mode
story.refreshTiddler(this.tiddler,null,true);
else // the TAGGED tiddler in edit mode (with tags field)
config.macros.checkbox.refreshEditorTagField(this.tiddler,this.tag,this.checked);
}
if (this.refresh.tagging)
if (!story.isDirty(this.tag)) story.refreshTiddler(this.tag,null,true); // the TAGGING tiddler
}
}
if (!this.init && this.fn_clickAfter) // custom function hook to react to changes in checkbox state
{ try { eval(this.fn_clickAfter) } catch(e) { displayMessage("Checkbox onClickAfter error: "+e.toString()); } }
// refresh containing tiddler (but not during initial rendering, or we get an infinite loop!) (and not when editing container)
if (!this.init && this.refresh.container && this.container!=this.tiddler)
if (!story.isDirty(this.container)) story.refreshTiddler(this.container,null,true); // the tiddler CONTAINING the checkbox
return true;
},
refreshEditorTagField: function(title,tag,set) {
var tagfield=story.getTiddlerField(title,"tags");
if (!tagfield||tagfield.getAttribute("edit")!="tags") return; // if no tags field in editor (i.e., custom template)
var tags=tagfield.value.readBracketedList();
if (tags.contains(tag)==set) return; // if no change needed
if (set) tags.push(tag); // add tag
else tags.splice(tags.indexOf(tag),1); // remove tag
for (var t=0;t<tags.length;t++) tags[t]=String.encodeTiddlyLink(tags[t]);
tagfield.value=tags.join(" "); // reassemble tag string (with brackets as needed)
return;
}
}
//}}}
/***
|''Name:''|Based on CollapseTiddlersPlugin|
|''Source:''|http://gensoft.revhost.net/Collapse.html|
|''Author:''|Bradley Meck|
|''License:''|unknown|
|''~CoreVersion:''|2.0.10|
|JOS 9/14/2006: changed text for 'collapse all' and 'expand all' to lower-case (consistency's sake); cleanned-up syntax (readability's sake) |
|JOS 9/14/2006: removed "WebCollapsedTemplate" altogether; added compat code for topOfPageMode; added tool tips for collapseAll and expandAll |
|ELS 2/24/2006: added fallback to "CollapsedTemplate if "WebCollapsedTemplate" is not found |
|ELS 2/6/2006: added check for 'readOnly' flag to use alternative "WebCollapsedTemplate" |
***/
//{{{
config.commands.collapseTiddler = {
text: "fold",
tooltip: "Collapse this tiddler",
handler: function(event,src,title){
var e = story.findContainingTiddler(src);
var t = "CollapsedTemplate";
if (!store.tiddlerExists(t)) { alert("Can't find 'CollapsedTemplate'"); return; }
if (config.options.chkTopOfPageMode!=undefined) {
var pm=config.options.chkTopOfPageMode;
config.options.chkTopOfPageMode=false;
}
if(e.getAttribute("template") != config.tiddlerTemplates[DEFAULT_EDIT_TEMPLATE]){
if(e.getAttribute("template") != t ){
e.setAttribute("oldTemplate",e.getAttribute("template"));
story.displayTiddler(null,title,t);
}
}
if (config.options.chkTopOfPageMode!=undefined) config.options.chkTopOfPageMode=pm;
}
}
config.commands.expandTiddler = {
text: "unfold",
tooltip: "Expand this tiddler",
handler: function(event,src,title){
if (config.options.chkTopOfPageMode!=undefined) {
var pm=config.options.chkTopOfPageMode;
config.options.chkTopOfPageMode=false;
}
var e = story.findContainingTiddler(src);
story.displayTiddler(null,title,e.getAttribute("oldTemplate"));
if (config.options.chkTopOfPageMode!=undefined) config.options.chkTopOfPageMode=pm;
}
}
config.macros.collapseAll = {
handler: function(place,macroName,params,wikifier,paramString,tiddler){
createTiddlyButton(place,"collapse all","Collapse all tiddlers",function(){
var t = "CollapsedTemplate";
if (!store.tiddlerExists(t)) { alert("Can't find 'CollapsedTemplate'"); return; }
if (config.options.chkTopOfPageMode!=undefined) {
var pm=config.options.chkTopOfPageMode;
config.options.chkTopOfPageMode=false;
}
story.forEachTiddler(function(title,tiddler){
if(tiddler.getAttribute("template") != config.tiddlerTemplates[DEFAULT_EDIT_TEMPLATE])
story.displayTiddler(null,title,t);
})
if (config.options.chkTopOfPageMode!=undefined) config.options.chkTopOfPageMode=pm;
})
}
}
config.macros.expandAll = {
handler: function(place,macroName,params,wikifier,paramString,tiddler){
createTiddlyButton(place,"expand all","",function(){
var t = "CollapsedTemplate";
if (!store.tiddlerExists(t)) { alert("Can't find 'CollapsedTemplate'"); return; }
if (config.options.chkTopOfPageMode!=undefined) {
var pm=config.options.chkTopOfPageMode;
config.options.chkTopOfPageMode=false;
}
story.forEachTiddler(function(title,tiddler){
if(tiddler.getAttribute("template") == t) story.displayTiddler(null,title,tiddler.getAttribute("oldTemplate"));
})
if (config.options.chkTopOfPageMode!=undefined) config.options.chkTopOfPageMode=pm;
})
}
}
config.commands.collapseOthers = {
text: "focus",
tooltip: "Expand this tiddler and collapse all others",
handler: function(event,src,title){
var e = story.findContainingTiddler(src);
var t = "CollapsedTemplate";
if (!store.tiddlerExists(t)) { alert("Can't find 'CollapsedTemplate'"); return; }
if (config.options.chkTopOfPageMode!=undefined) {
var pm=config.options.chkTopOfPageMode;
config.options.chkTopOfPageMode=false;
}
story.forEachTiddler(function(title,tiddler){
if(tiddler.getAttribute("template") != config.tiddlerTemplates[DEFAULT_EDIT_TEMPLATE]){
if (tiddler!=e) story.displayTiddler(null,title,t);
}
})
if (config.options.chkTopOfPageMode!=undefined) config.options.chkTopOfPageMode=pm;
}
}
//}}}
/***
|Name|DatePlugin|
|Source|http://www.TiddlyTools.com/#DatePlugin|
|Documentation|http://www.TiddlyTools.com/#DatePluginInfo|
|Version|2.7.0|
|Author|Eric Shulman - ELS Design Studios|
|License|http://www.TiddlyTools.com/#LegalStatements <br>and [[Creative Commons Attribution-ShareAlike 2.5 License|http://creativecommons.org/licenses/by-sa/2.5/]]|
|~CoreVersion|2.1|
|Type|plugin|
|Requires||
|Overrides||
|Options|##Configuration|
|Description|formatted dates plus popup menu with 'journal' link, changes and (optional) reminders|
There are quite a few calendar generators, reminders, to-do lists, 'dated tiddlers' journals, blog-makers and GTD-like schedule managers that have been built around TW. While they all have different purposes, and vary in format, interaction, and style, in one way or another each of these plugins displays and/or uses date-based information to make finding, accessing and managing relevant tiddlers easier. This plugin provides a general approach to embedding dates and date-based links/menus within tiddler content.
!!!!!Documentation
>see [[DatePluginInfo]]
!!!!!Configuration
<<<
<<option chkDatePopupHideCreated>> omit 'created' section from date popups
<<option chkDatePopupHideChanged>> omit 'changed' section from date popups
<<option chkDatePopupHideTagged>> omit 'tagged' section from date popups
<<option chkDatePopupHideReminders>> omit 'reminders' section from date popups
<<option chkShowJulianDate>> display Julian day number (1-365) below current date
see [[DatePluginConfig]] for additional configuration settings, for use in calendar displays, including:
*date formats
*color-coded backgrounds
*annual fixed-date holidays
*weekends
<<<
!!!!!Revisions
<<<
2008.03.08 [2.7.0] in addModifiedsToPopup(), if a tiddler was created on the specified date, don't list it in the 'changed' section of the popup. Based on a request from Kashgarinn.
|please see [[DatePluginInfo]] for additional revision details|
2005.10.30 [0.9.0] pre-release
<<<
!!!!!Code
***/
//{{{
version.extensions.DatePlugin= {major: 2, minor: 7, revision: 0, date: new Date(2008,3,8)};
config.macros.date = {
format: "YYYY.0MM.0DD", // default date display format
linkformat: "YYYY.0MM.0DD", // 'dated tiddler' link format
linkedbg: "#babb1e", // "babble"
todaybg: "#ffab1e", // "fable"
weekendbg: "#c0c0c0", // "cocoa"
holidaybg: "#ffaace", // "face"
createdbg: "#bbeeff", // "beef"
modifiedsbg: "#bbeeff", // "beef"
remindersbg: "#c0ffee", // "coffee"
holidays: [ "01/01", "07/04", "07/24", "11/24" ], // NewYearsDay, IndependenceDay(US), Eric's Birthday (hooray!), Thanksgiving(US)
weekend: [ 1,0,0,0,0,0,1 ] // [ day index values: sun=0, mon=1, tue=2, wed=3, thu=4, fri=5, sat=6 ]
};
config.macros.date.handler = function(place,macroName,params)
{
// do we want to see a link, a popup, or just a formatted date?
var mode="display";
if (params[0]=="display") { mode=params[0]; params.shift(); }
if (params[0]=="popup") { mode=params[0]; params.shift(); }
if (params[0]=="link") { mode=params[0]; params.shift(); }
// get the date
var now = new Date();
var date = now;
if (!params[0] || params[0]=="today")
{ params.shift(); }
else if (params[0]=="filedate")
{ date=new Date(document.lastModified); params.shift(); }
else if (params[0]=="tiddler")
{ date=store.getTiddler(story.findContainingTiddler(place).id.substr(7)).modified; params.shift(); }
else if (params[0].substr(0,8)=="tiddler:")
{ var t; if ((t=store.getTiddler(params[0].substr(8)))) date=t.modified; params.shift(); }
else {
var y = eval(params.shift().replace(/Y/ig,(now.getYear()<1900)?now.getYear()+1900:now.getYear()));
var m = eval(params.shift().replace(/M/ig,now.getMonth()+1));
var d = eval(params.shift().replace(/D/ig,now.getDate()+0));
date = new Date(y,m-1,d);
}
// date format with optional custom override
var format=this.format; if (params[0]) format=params.shift();
var linkformat=this.linkformat; if (params[0]) linkformat=params.shift();
showDate(place,date,mode,format,linkformat);
}
window.showDate=showDate;
function showDate(place,date,mode,format,linkformat,autostyle,weekend)
{
if (!mode) mode="display";
if (!format) format=config.macros.date.format;
if (!linkformat) linkformat=config.macros.date.linkformat;
if (!autostyle) autostyle=false;
// format the date output
var title = date.formatString(format);
var linkto = date.formatString(linkformat);
// just show the formatted output
if (mode=="display") { place.appendChild(document.createTextNode(title)); return; }
// link to a 'dated tiddler'
var link = createTiddlyLink(place, linkto, false);
link.appendChild(document.createTextNode(title));
link.title = linkto;
link.date = date;
link.format = format;
link.linkformat = linkformat;
// if using a popup menu, replace click handler for dated tiddler link
// with handler for popup and make link text non-italic (i.e., an 'existing link' look)
if (mode=="popup") {
link.onclick = onClickDatePopup;
link.style.fontStyle="normal";
}
// format the popup link to show what kind of info it contains (for use with calendar generators)
if (autostyle) setDateStyle(place,link,weekend);
}
//}}}
//{{{
// NOTE: This function provides default logic for setting the date style when displayed in a calendar
// To customize the date style logic, please see[[DatePluginConfig]]
function setDateStyle(place,link,weekend) {
// alias variable names for code readability
var date=link.date;
var fmt=link.linkformat;
var linkto=date.formatString(fmt);
var cmd=config.macros.date;
if ((weekend!==undefined?weekend:isWeekend(date))&&(cmd.weekendbg!=""))
{ place.style.background = cmd.weekendbg; }
if (hasModifieds(date)||hasCreateds(date)||hasTagged(date,fmt))
{ link.style.fontStyle="normal"; link.style.fontWeight="bold"; }
if (hasReminders(date))
{ link.style.textDecoration="underline"; }
if (isToday(date))
{ link.style.border="1px solid black"; }
if (isHoliday(date)&&(cmd.holidaybg!=""))
{ place.style.background = cmd.holidaybg; }
if (hasCreateds(date)&&(cmd.createdbg!=""))
{ place.style.background = cmd.createdbg; }
if (hasModifieds(date)&&(cmd.modifiedsbg!=""))
{ place.style.background = cmd.modifiedsbg; }
if ((hasTagged(date,fmt)||store.tiddlerExists(linkto))&&(cmd.linkedbg!=""))
{ place.style.background = cmd.linkedbg; }
if (hasReminders(date)&&(cmd.remindersbg!=""))
{ place.style.background = cmd.remindersbg; }
if (isToday(date)&&(cmd.todaybg!=""))
{ place.style.background = cmd.todaybg; }
if (config.options.chkShowJulianDate) { // optional display of Julian date numbers
var m=[0,31,59,90,120,151,181,212,243,273,304,334];
var d=date.getDate()+m[date.getMonth()];
var y=date.getFullYear();
if (date.getMonth()>1 && (y%4==0 && y%100!=0) || y%400==0)
d++; // after February in a leap year
wikify("@@font-size:80%;<br>"+d+"@@",place);
}
}
//}}}
//{{{
function isToday(date) // returns true if date is today
{ var now=new Date(); return ((now-date>=0) && (now-date<86400000)); }
function isWeekend(date) // returns true if date is a weekend
{ return (config.macros.date.weekend[date.getDay()]); }
function isHoliday(date) // returns true if date is a holiday
{
var longHoliday = date.formatString("0MM/0DD/YYYY");
var shortHoliday = date.formatString("0MM/0DD");
for(var i = 0; i < config.macros.date.holidays.length; i++) {
var holiday=config.macros.date.holidays[i];
if (holiday==longHoliday||holiday==shortHoliday) return true;
}
return false;
}
//}}}
//{{{
// Event handler for clicking on a day popup
function onClickDatePopup(e)
{
if (!e) var e = window.event;
var theTarget = resolveTarget(e);
var popup = Popup.create(this);
if(popup) {
// always show dated tiddler link (or just date, if readOnly) at the top...
if (!readOnly || store.tiddlerExists(this.date.formatString(this.linkformat)))
createTiddlyLink(popup,this.date.formatString(this.linkformat),true);
else
createTiddlyText(popup,this.date.formatString(this.linkformat));
if (!config.options.chkDatePopupHideCreated)
addCreatedsToPopup(popup,this.date,this.format);
if (!config.options.chkDatePopupHideChanged)
addModifiedsToPopup(popup,this.date,this.format);
if (!config.options.chkDatePopupHideTagged)
addTaggedToPopup(popup,this.date,this.linkformat);
if (!config.options.chkDatePopupHideReminders)
addRemindersToPopup(popup,this.date,this.linkformat);
}
Popup.show(popup,false);
e.cancelBubble = true;
if (e.stopPropagation) e.stopPropagation();
return(false);
}
//}}}
//{{{
function indexCreateds() // build list of tiddlers, hash indexed by creation date
{
var createds= { };
var tiddlers = store.getTiddlers("title","excludeLists");
for (var t = 0; t < tiddlers.length; t++) {
var date = tiddlers[t].created.formatString("YYYY0MM0DD")
if (!createds[date])
createds[date]=new Array();
createds[date].push(tiddlers[t].title);
}
return createds;
}
function hasCreateds(date) // returns true if date has created tiddlers
{
if (!config.macros.date.createds) config.macros.date.createds=indexCreateds();
return (config.macros.date.createds[date.formatString("YYYY0MM0DD")]!=undefined);
}
function addCreatedsToPopup(popup,when,format)
{
var force=(store.isDirty() && when.formatString("YYYY0MM0DD")==new Date().formatString("YYYY0MM0DD"));
if (force || !config.macros.date.createds) config.macros.date.createds=indexCreateds();
var indent=String.fromCharCode(160)+String.fromCharCode(160);
var createds = config.macros.date.createds[when.formatString("YYYY0MM0DD")];
if (createds) {
createds.sort();
var e=createTiddlyElement(popup,"div",null,null,"created ("+createds.length+")");
for(var t=0; t<createds.length; t++) {
var link=createTiddlyLink(popup,createds[t],false);
link.appendChild(document.createTextNode(indent+createds[t]));
createTiddlyElement(popup,"br",null,null,null);
}
}
}
//}}}
//{{{
function indexModifieds() // build list of tiddlers, hash indexed by modification date
{
var modifieds= { };
var tiddlers = store.getTiddlers("title","excludeLists");
for (var t = 0; t < tiddlers.length; t++) {
var date = tiddlers[t].modified.formatString("YYYY0MM0DD")
if (!modifieds[date])
modifieds[date]=new Array();
modifieds[date].push(tiddlers[t].title);
}
return modifieds;
}
function hasModifieds(date) // returns true if date has modified tiddlers
{
if (!config.macros.date.modifieds) config.macros.date.modifieds = indexModifieds();
return (config.macros.date.modifieds[date.formatString("YYYY0MM0DD")]!=undefined);
}
function addModifiedsToPopup(popup,when,format)
{
var date=when.formatString("YYYY0MM0DD");
var force=(store.isDirty() && date==new Date().formatString("YYYY0MM0DD"));
if (force || !config.macros.date.modifieds) config.macros.date.modifieds=indexModifieds();
var indent=String.fromCharCode(160)+String.fromCharCode(160);
var mods = config.macros.date.modifieds[date];
if (mods) {
// if a tiddler was created on this date, don't list it in the 'changed' section
if (config.macros.date.createds && config.macros.date.createds[date]) {
var temp=[];
for(var t=0; t<mods.length; t++)
if (!config.macros.date.createds[date].contains(mods[t]))
temp.push(mods[t]);
mods=temp;
}
mods.sort();
var e=createTiddlyElement(popup,"div",null,null,"changed ("+mods.length+")");
for(var t=0; t<mods.length; t++) {
var link=createTiddlyLink(popup,mods[t],false);
link.appendChild(document.createTextNode(indent+mods[t]));
createTiddlyElement(popup,"br",null,null,null);
}
}
}
//}}}
//{{{
function hasTagged(date,format) // returns true if date is tagging other tiddlers
{
return store.getTaggedTiddlers(date.formatString(format)).length>0;
}
function addTaggedToPopup(popup,when,format)
{
var indent=String.fromCharCode(160)+String.fromCharCode(160);
var tagged=store.getTaggedTiddlers(when.formatString(format));
if (tagged.length) var e=createTiddlyElement(popup,"div",null,null,"tagged ("+tagged.length+")");
for(var t=0; t<tagged.length; t++) {
var link=createTiddlyLink(popup,tagged[t].title,false);
link.appendChild(document.createTextNode(indent+tagged[t].title));
createTiddlyElement(popup,"br",null,null,null);
}
}
//}}}
//{{{
function indexReminders(date,leadtime) // build list of tiddlers with reminders, hash indexed by reminder date
{
var reminders = { };
if(window.findTiddlersWithReminders!=undefined) { // reminder plugin is installed
// DEBUG var starttime=new Date();
var t = findTiddlersWithReminders(date, [0,leadtime], null, null, 1);
for(var i=0; i<t.length; i++) reminders[t[i].matchedDate]=true;
// DEBUG var out="Found "+t.length+" reminders in "+((new Date())-starttime+1)+"ms\n";
// DEBUG out+="startdate: "+date.toLocaleDateString()+"\n"+"leadtime: "+leadtime+" days\n\n";
// DEBUG for(var i=0; i<t.length; i++) { out+=t[i].matchedDate.toLocaleDateString()+" "+t[i].params.title+"\n"; }
// DEBUG alert(out);
}
return reminders;
}
function hasReminders(date) // returns true if date has reminders
{
if (window.reminderCacheForCalendar)
return window.reminderCacheForCalendar[date]; // use calendar cache
if (!config.macros.date.reminders)
config.macros.date.reminders = indexReminders(date,90); // create a 90-day leadtime reminder cache
return (config.macros.date.reminders[date]);
}
function addRemindersToPopup(popup,when,format)
{
if(window.findTiddlersWithReminders==undefined) return; // reminder plugin not installed
var indent = String.fromCharCode(160)+String.fromCharCode(160);
var reminders=findTiddlersWithReminders(when, [0,31],null,null,1);
createTiddlyElement(popup,"div",null,null,"reminders ("+(reminders.length||"none")+")");
for(var t=0; t<reminders.length; t++) {
link = createTiddlyLink(popup,reminders[t].tiddler,false);
var diff=reminders[t].diff;
diff=(diff<1)?"Today":((diff==1)?"Tomorrow":diff+" days");
var txt=(reminders[t].params["title"])?reminders[t].params["title"]:reminders[t].tiddler;
link.appendChild(document.createTextNode(indent+diff+" - "+txt));
createTiddlyElement(popup,"br",null,null,null);
}
if (readOnly) return; // omit "new reminder..." link
var link = createTiddlyLink(popup,indent+"new reminder...",true); createTiddlyElement(popup,"br");
var title = when.formatString(format);
link.title="add a reminder to '"+title+"'";
link.onclick = function() {
// show tiddler editor
story.displayTiddler(null, title, 2, null, null, false, false);
// find body 'textarea'
var c =document.getElementById("tiddler" + title).getElementsByTagName("*");
for (var i=0; i<c.length; i++) if ((c[i].tagName.toLowerCase()=="textarea") && (c[i].getAttribute("edit")=="text")) break;
// append reminder macro to tiddler content
if (i<c.length) {
if (store.tiddlerExists(title)) c[i].value+="\n"; else c[i].value="";
c[i].value += "<<reminder";
c[i].value += " day:"+when.getDate();
c[i].value += " month:"+(when.getMonth()+1);
c[i].value += " year:"+when.getFullYear();
c[i].value += ' title:"Enter a title" >>';
}
};
}
//}}}
<<list filter "[tag[FontInfo]]">>
----
MkDirは1階層分だけディレクトリを作成
ForceDirectoryは、なんぼでもOK
<<list filter "[tag[DelphiForm]]">>
他のFormのイベントで操作する場合は、OwnerをSelfにする。
.dprや、initialozation の定義内で行う場合はApplicationを使用する。
たとえば、
{{{
type
TMyForm1 = class( TForm)
...
end;
TMyForm2 = class( TForm)
FMyForm1 : TMyForm1;
...
end;
var
FMyForm1_1 : TMyForm1;
implementation
procedure TMyForm2.FormCreate( Sender : TObject );
begin
...
FMyForm1 := TMyForm1.Create( Self );
end;
procedure TMyForm2.FormDestroy(Sender: TObject);
begin
...
FMyForm1.free;
end;
procedure TMyForm2.SelectClick(Sender: TObject);
var
MyDlg : TMyForm1;
begin
MyDlg := TMyForm1.Create( Self );
try
MyDlg.ShowModal;
finally
MyDlg.free;
end;
end;
Initialization
FMyForm1_1 := TMyForm1.Create( Application );
finalization
FMyForm1_1.free;
}}}
TFormのクラスのメンバとして定義したフォームのクラスは、そのフォームを破棄するときに自動的に破棄されます。
これは、FormDestroyを呼ぶ前に行われますので、TFormクラスのfreeは不要です。もし行うと、一般保護が発生します。
ただし、動作の途中で破棄を行うのは問題無しです。このときは、メンバをnilにするのを忘れてはいけません。
注：Form以外のコンポーネントをメンバに定義した場合も同様です。
Formを中央に表示する場合の指定としてpositionプロパティに「poDeskTopCenter」と「poScreenCenter」の指定が可能。
poDeskTopCenterの場合はマルチモニタ環境の場合に画面にまたがって表示される
poScreenCenterなら一方のモニタの中央になります。
Formの位置調整 下のprocedureをライブラリに入れる。
んで、FormShow の中で AdjustWindowForm( Self )を行うと、画面に入る。
----
uses Forms , Windows を使用する。
{{{
//---- Window(TCustonForm）をウィンドウ内に
// 移動-------------------------------
// 位置を補正した場合は、TRUE
// 位置が変わっていない場合は FALSE
function AdjustWindowForm(
objWin : TCustomForm )
: boolean;
var
screen_width,
screen_height : integer;
screen_top,
screen_bottom,
screen_left,
screen_right : integer;
iBottom,
iRight: integer;
iWk : integer;
begin
result := false;
// get screen size
screen_width := GetSystemMetrics( SM_CXSCREEN );
screen_height := GetSystemMetrics( SM_CYSCREEN );
// get screen rect
screen_top := 0;
screen_bottom := screen_height -1;
screen_left := 0;
screen_right := screen_width - 1;
if objWin.Top < screen_top then
begin
// sticks out above.
objWin.Top := screen_top;
result := true;
end
else begin
// sticks out below.
iBottom := objWin.Top + objWin.Height;
if iBottom > screen_bottom then
begin
iWk := objWin.Top - ( iBottom - screen_bottom );
if iWk < screen_top then iWk := screen_top;
objWin.Top := iWk;
end;
result := true;
end;
if objWin.Left < screen_left then
begin
// sticks out above.
objWin.Left := screen_left;
result := true;
end
else begin
// sticks out below.
iRight := objWin.Left + objWin.Width;
if iRight > screen_right then
begin
iWk := objWin.Left - ( iRight - screen_right );
if iWk < screen_left then iWk := screen_left;
objWin.Left := iWk;
end;
result := true;
end;
end;
}}}
sample (AdjustWindows.pas)
{{{
unit AdjustWindowUnit;
interface
uses
Forms;
//---- Window(TCustonForm）をウィンドウ内に
// 移動-------------------------------
// 位置を補正した場合は、TRUE
// 位置が変わっていない場合は FALSE
function AdjustWindowForm(
objWin : TCustomForm ) : boolean;
implementation
uses
windows;
//---- Window(TCustonForm）をウィンドウ内に
// 移動-------------------------------
// 位置を補正した場合は、TRUE
// 位置が変わっていない場合は FALSE
function AdjustWindowForm(
objWin : TCustomForm ) : boolean;
var
screen_width,
screen_height : integer;
screen_top,
screen_bottom,
screen_left,
screen_right : integer;
iBottom,
iRight: integer;
iWk : integer;
begin
result := false;
// get screen size
screen_width := GetSystemMetrics( SM_CXSCREEN );
screen_height := GetSystemMetrics( SM_CYSCREEN );
// get screen rect
screen_top := 0;
screen_bottom := screen_height -1;
screen_left := 0;
screen_right := screen_width - 1;
if objWin.Top < screen_top then
begin
// sticks out above.
objWin.Top := screen_top;
result := true;
end
else
begin
// sticks out below.
iBottom := objWin.Top + objWin.Height;
if iBottom > screen_bottom then
begin
iWk := objWin.Top - ( iBottom - screen_bottom );
if iWk < screen_top then
iWk := screen_top;
objWin.Top := iWk;
result := true;
end;
end;
if objWin.Left < screen_left then
begin
// sticks out above.
objWin.Left := screen_left;
result := true;
end
else
begin
// sticks out below.
iRight := objWin.Left + objWin.Width;
if iRight > screen_right then
begin
iWk := objWin.Left - ( iRight - screen_right );
if iWk < screen_left then
iWk := screen_left;
objWin.Left := iWk;
result := true;
end;
end;
end;
end.
}}}
Formのサイズ制限
Constraints プロパティのMaxHeightなどの設定でサイズ制限が可能。
これにより、マウスでウィンドウのサイズを調整した際の最大サイズを制限可能です。
同じEXE内の特定のフォームからOnCreateやOnShowイベントで、他のフォームへのアクセスを行う場合は、
フォームのCreateをメインのソースで行うため、作成されていないFormへのアクセスになってしまい一般保護発生する可能性がある。
また、メインのソースをいじって、Createの順番を変更すると、メインフォームが変わる可能性があり、動作がおかしくなる場合があります。
この場合は、アクセスされる側のフォームはメインのソースでCreateするのをやめて、呼び出し側のフォームからCreateを行ってアクセスすると言う方法で、一般保護は動作の問題が解決します。
----
{{{
if a = 1 then
b := true
else
b := false;
}}}
↓
{{{
b := ( a = 1 );
}}}
----
とする。
<<list filter "[tag[Indy10調査データ]]">>
Delphi7の標準はIndy9がインストールされている。
Indy9ではSMTP認証機能が不十分など、最新のネットワーク環境では十分に使用できない。
Indy10であれば大分対応が進んでいる。
/***
|''Name:''|JapaneseTranslationPlugin |
|''Description:''|Translation of TiddlyWiki into Japanese |
|''Author:''|OGOSHI Masayuki <ogoshima@gmail.com> |
|''Source:''|http://ogoshi.tiddlyspot.com/#JapaneseTranslationPlugin |
|''Version:''|0.3.7.1-ja|
|''Date:''|Sep 04, 2008|
|''License:''|[[Creative Commons Attribution-ShareAlike 2.1 Japan |http://creativecommons.org/licenses/by-sa/2.1/jp/]] |
|''~CoreVersion:''|2.4|
TiddlyWiki を日本語化するプラグイン。TiddlyWiki Version 2.4 上で動作を確認しました。
ライセンスは英語版のCCライセンスに準じる日本語版の CC-by-SA 2.1 ライセンスとします。
英語版のクレジットは以下のとおり。
|''Name:''|EnglishTranslationPlugin|
|''Description:''|Translation of TiddlyWiki into English|
|''Author:''|MartinBudden (mjbudden (at) gmail (dot) com)|
|''Source:''|www.example.com |
|''CodeRepository:''|http://svn.tiddlywiki.org/Trunk/association/locales/core/en/locale.en.js |
|''Version:''|0.3.7|
|''Date:''|Jul 6, 2007|
|''Comments:''|Please make comments at http://groups.google.co.uk/group/TiddlyWikiDev |
|''License:''|[[Creative Commons Attribution-ShareAlike 3.0 License|http://creativecommons.org/licenses/by-sa/3.0/]] |
|''~CoreVersion:''|2.4|
***/
//{{{
//--
//-- Translateable strings
//--
// Strings in "double quotes" should be translated; strings in 'single quotes' should be left alone
config.locale = "ja"; // W3C language tag
if (config.options.txtUserName == 'YourName') // do not translate this line, but do translate the next line
merge(config.options,{txtUserName: "氏名"});
merge(config.tasks,{
save: {text: "保存", tooltip: "このTiddlyWikiを保存します", action: saveChanges},
sync: {text: "同期", tooltip: "他のTiddlyWikiファイルやサーバと同期をとります", content: '<<sync>>'},
importTask: {text: "取り込み", tooltip: "他のTiddlyWikiファイルやサーバからtiddlerやプラグインを取り込みます", content: '<<importTiddlers>>'},
tweak: {text: "詳細設定", tooltip: "TiddlyWikiの細かな振る舞いを設定します", content: '<<options>>'},
upgrade: {text: "アップグレード", tooltip: "TiddlyWiki本体をバージョンアップします", content: '<<upgrade>>'},
plugins: {text: "プラグイン", tooltip: "インストール済みのプラグインを管理します", content: '<<plugins>>'}
});
// Options that can be set in the options panel and/or cookies
merge(config.optionsDesc,{
txtUserName: "編集したtiddlerに記録されるユーザ名",
chkRegExpSearch: "検索に正規表現を使います",
chkCaseSensitiveSearch: "検索で大文字小文字を区別します",
chkIncrementalSearch: "インクリメンタルサーチを行います",
chkAnimate: "アニメーションを許可します",
chkSaveBackups: "保存時にバックアップファイルを残します",
chkAutoSave: "自動保存します",
chkGenerateAnRssFeed: "保存時にRSSフィードを生成します",
chkSaveEmptyTemplate: "空のテンプレートファイルを保存時に生成します",
chkOpenInNewWindow: "外部へのリンクを新しいウィンドウで開きます",
chkToggleLinks: "tiddlerへのリンククリックでtiddlerを閉じます",
chkHttpReadOnly: "HTTP経由で開いているときに編集機能を隠します",
chkForceMinorUpdate: "更新時にユーザ名と日付を変更しません",
chkConfirmDelete: "tiddlerを消去する時に確認をします",
chkInsertTabs: "タブキーを押したとき、フィールド間の移動ではなくタブ文字を挿入します",
txtBackupFolder: "バックアップ用フォルダの名前",
txtMaxEditRows: "編集領域の最大行数",
txtFileSystemCharSet: "保存時のデフォルト文字コード(Firefox/Mozillaのみ)"});
merge(config.messages,{
customConfigError: "プラグインの読み込み時に問題が発生しました。詳細は PluginManager をご覧ください",
pluginError: "エラー: %0",
pluginDisabled: "'systemConfigDisable'タグによって実行が禁止されています",
pluginForced: "'systemConfigForce'タグによって強制実行されました",
pluginVersionError: "このプラグインの実行には、新しいバージョンの TiddlyWiki が必要です。",
nothingSelected: "何も選択されていません。一つ以上選択する必要があります。",
savedSnapshotError: "この~TiddlyWikiは正常に保存されていません。詳細は http://www.tiddlywiki.com/#DownloadSoftware をご覧ください。",
subtitleUnknown: "(unknown)",
undefinedTiddlerToolTip: "この tiddler '%0' はまだ作成されていません",
shadowedTiddlerToolTip: "この tiddler '%0' はまだ作成されていませんが、隠された規定値があります",
tiddlerLinkTooltip: "%0 - %1, %2",
externalLinkTooltip: "(外部へのリンク) %0",
noTags: "タグの付いた tiddler はありません",
notFileUrlError: "変更を保存するにはこの~TiddlyWikiをファイルとして保存(ダウンロード)する必要があります",
cantSaveError: "変更を保存できませんでした。以下の理由が考えられます:\n- 使用しているブラウザが保存に対応していない(Firefox/Internet Explorer/Safari/Operaは、正しく設定していれば保存できます)\n- TiddlyWikiファイルの保存path名に不正な文字が含まれている\n- TiddlyWiki HTMLファイルが移動または名前を変更された",
invalidFileError: "元のファイル '%0' は正しい~TiddlyWikiファイルではありません",
backupSaved: "バックアップを保存しました",
backupFailed: "バックアップの保存に失敗しました",
rssSaved: "RSSフィードを保存しました",
rssFailed: "RSSフィードの保存に失敗しました",
emptySaved: "空のテンプレートファイルを保存しました",
emptyFailed: "空のテンプレートファイルの保存に失敗しました",
mainSaved: "TiddlyWikiファイルを保存しました",
mainFailed: "TiddlyWikiファイルの保存に失敗しました。変更した内容は保存されていません",
macroError: "次のマクロでエラー発生 <<\%0>>",
macroErrorDetails: "次のマクロを実行中にエラー発生 <<\%0>>:\n%1",
missingMacro: "マクロがありません",
overwriteWarning: "'%0'という名前のtiddlerはすでに存在します。OKで上書きします",
unsavedChangesWarning: "注意! TiddlyWiki の変更が保存されていません。\n\n'OK'で保存\n'キャンセル'で変更を破棄",
confirmExit: "--------------------------------\n\nTiddlyWikiの変更が保存されていません。このまま続けると変更が失われます\n\n--------------------------------",
saveInstructions: "変更を保存",
unsupportedTWFormat: "次の TiddlyWiki フォーマットには対応していません '%0'",
tiddlerSaveError: "tiddler '%0' を保存時にエラー発生",
tiddlerLoadError: "tiddler '%0' の読込時にエラー発生",
wrongSaveFormat: "保存フォーマット '%0' で保存できません。標準フォーマットで保存します",
invalidFieldName: "%0 は不正なファイル名です",
fieldCannotBeChanged: "領域 '%0' は変更できません",
loadingMissingTiddler: "tiddler '%0' の '%1' サーバーからの回復を試しています:\n\nワークスペース '%3' の中の '%2'",
upgradeDone: "バージョン %0 へのアップグレードが完了しました。\n'OK' をクリックすると新しくなったTiddlyWikiをリロードします。"});
merge(config.messages.messageClose,{
text: "閉じる",
tooltip: "このメッセージを閉じます"});
config.messages.backstage = {
open: {text: "クイックメニュー", tooltip: "クイックメニューを開きます"},
close: {text: "閉じる", tooltip: "クイックメニューを閉じます"},
prompt: "クイックメニュー: ",
decal: {
edit: {text: "編集", tooltip: "tiddler '%0' を編集します"}
}
};
config.messages.listView = {
tiddlerTooltip: "このtiddlerのテキスト全体を表示します",
previewUnavailable: "(プレビューがありません)"
};
config.messages.dates.months = ["1月", "2月", "3月", "4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月","12月"];
config.messages.dates.days = ["日曜日", "月曜日", "火曜日", "水曜日", "木曜日", "金曜日", "土曜日"];
config.messages.dates.shortMonths = ["1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12"];
config.messages.dates.shortDays = ["日", "月", "火", "水", "木", "金", "土"];
// suffixes for dates, eg "1st","2nd","3rd"..."30th","31st"
config.messages.dates.daySuffixes = ["日","日","日","日","日","日","日","日","日","日",
"日","日","日","日","日","日","日","日","日","日",
"日","日","日","日","日","日","日","日","日","日",
"日"];
config.messages.dates.am = "am";
config.messages.dates.pm = "pm";
merge(config.messages.tiddlerPopup,{
});
merge(config.views.wikified.tag,{
labelNoTags: "タグ無し",
labelTags: "タグ: ",
openTag: "'%0' タグを開く",
tooltip: "'%0' タグの付いたtiddlerを表示",
openAllText: "全て開く",
openAllTooltip: "以下のtiddlerを全て開く",
popupNone: "'%0' タグの付いたtiddlerは他にありません"});
merge(config.views.wikified,{
defaultText: "tiddler '%0' はまだ作成されていません。ダブルクリックで作成できます",
defaultModifier: "(missing)",
shadowModifier: "(built-in shadow tiddler)",
dateFormat: "YYYY.MM.DD", // use this to change the date format for your locale, eg "YYYY MMM DD", do not translate the Y, M or D
createdPrompt: "作成"});
merge(config.views.editor,{
tagPrompt: "スペース区切りでタグを入力。スペースを含める場合は[[二重の角括弧]]で囲みます。既存のタグを選択≫",
defaultText: "'%0' の内容を入力してください"});
merge(config.views.editor.tagChooser,{
text: "タグ",
tooltip: "既存のタグを選択して追加します",
popupNone: "タグが定義されていません",
tagTooltip: "'%0' タグを追加します"});
merge(config.messages,{
sizeTemplates:
[
{unit: 1024*1024*1024, template: "%0\u00a0GB"},
{unit: 1024*1024, template: "%0\u00a0MB"},
{unit: 1024, template: "%0\u00a0KB"},
{unit: 1, template: "%0\u00a0B"}
]});
merge(config.macros.search,{
label: "検索",
prompt: "この TiddlyWiki 内を検索します",
accessKey: "F",
successMsg: "%0 件のtiddlerで %1 が見つかりました",
failureMsg: "%0 は見つかりませんでした"});
merge(config.macros.tagging,{
label: "タグあり: ",
labelNotTag: "タグなし",
tooltip: "'%0' タグを付けたtiddlerリスト"});
merge(config.macros.timeline,{
dateFormat: "YYYY年MM月DD日"});// use this to change the date format for your locale, eg "YYYY MMM DD", do not translate the Y, M or D
merge(config.macros.allTags,{
tooltip: "'%0' タグの付いたtiddlerを表示",
noTags: "タグの付いたtiddlerがありません"});
config.macros.list.all.prompt = "アルファベット順 全tiddler";
config.macros.list.missing.prompt = "リンクがあるのに存在しないtiddler";
config.macros.list.orphans.prompt = "どこからもリンクされていないtiddler";
config.macros.list.shadowed.prompt = "規定で隠されているtiddler";
config.macros.list.touched.prompt = "ローカルに変更されているtiddler";
merge(config.macros.closeAll,{
label: "全て閉じる",
prompt: "表示されている全てのtiddlerを閉じます (編集中を除く)"});
merge(config.macros.permaview,{
label: "現況リンク",
prompt: "現在のtiddler表示状態を再現するURLをアドレス欄に生成します"});
merge(config.macros.saveChanges,{
label: "保存",
prompt: "全てのtiddlerを保存します",
accessKey: "S"});
merge(config.macros.newTiddler,{
label: "新規作成",
prompt: "新しいtiddlerを作成します",
title: "新規作成",
accessKey: "N"});
merge(config.macros.newJournal,{
label: "新規ジャーナル",
prompt: "現在日時がタイトルの新しいtiddlerを作成します",
accessKey: "J"});
merge(config.macros.options,{
wizardTitle: "詳細設定",
step1Title: "これらのオプション設定はブラウザのcookieに保存されます",
step1Html: "<input type='hidden' name='markList'></input><br><input type='checkbox' checked='false' name='chkUnknown'>未知のオプションを表示</input>",
unknownDescription: "//(未知)//",
listViewTemplate: {
columns: [
{name: 'Option', field: 'option', title: "オプション設定", type: 'String'},
{name: 'Description', field: 'description', title: "説明", type: 'WikiText'},
{name: 'Name', field: 'name', title: "オプション名", type: 'String'}
],
rowClasses: [
{className: 'lowlight', field: 'lowlight'}
]}
});
merge(config.macros.plugins,{
wizardTitle: "プラグイン管理",
step1Title: "ロードされているプラグイン",
step1Html: "<input type='hidden' name='markList'></input>", // DO NOT TRANSLATE
skippedText: "(このプラグインは起動後に追加されたので実行されていません)",
noPluginText: "プラグインはインストールされていません",
confirmDeleteText: "本当にこのプラグインを削除して良いですか?:\n\n%0",
removeLabel: "systemConfig タグを除去",
removePrompt: "systemConfig タグを除去します",
deleteLabel: "削除",
deletePrompt: "これらのtiddlerを削除します",
listViewTemplate: {
columns: [
{name: 'Selected', field: 'Selected', rowName: 'title', type: 'Selector'},
{name: 'Tiddler', field: 'tiddler', title: "Tiddler", type: 'Tiddler'},
{name: 'Size', field: 'size', tiddlerLink: 'size', title: "サイズ", type: 'Size'},
{name: 'Forced', field: 'forced', title: "強制実行", tag: 'systemConfigForce', type: 'TagCheckbox'},
{name: 'Disabled', field: 'disabled', title: "無効化", tag: 'systemConfigDisable', type: 'TagCheckbox'},
{name: 'Executed', field: 'executed', title: "ロード済み", type: 'Boolean', trueText: "Yes", falseText: "No"},
{name: 'Startup Time', field: 'startupTime', title: "起動時実行", type: 'String'},
{name: 'Error', field: 'error', title: "ステータス", type: 'Boolean', trueText: "Error", falseText: "OK"},
{name: 'Log', field: 'log', title: "ログ", type: 'StringList'}
],
rowClasses: [
{className: 'error', field: 'error'},
{className: 'warning', field: 'warning'}
]}
});
merge(config.macros.toolbar,{
moreLabel: "その他",
morePrompt: "その他のコマンドも表示します"
});
merge(config.macros.refreshDisplay,{
label: "再表示",
prompt: "TiddlyWiki全体を再描画します"
});
merge(config.macros.importTiddlers,{
readOnlyWarning: "読込専用のTiddlyWikiには取り込めません。TiddlyWikiファイルを file:// 形式のURLで開いてみてください",
wizardTitle: "他のファイルあるいはサーバーからtiddlerを取り込む",
step1Title: "手順 1: TiddlyWikiファイルあるいはサーバーの位置を指定します",
step1Html: "種別指定: <select name='selTypes'><option value=''>選択...</option></select><br>URLまたはパス名を入力: <input type='text' size=50 name='txtPath'><br>またはファイルを選択: <input type='file' size=50 name='txtBrowse'><br><hr>または既定のフィードを選択: <select name='selFeeds'><option value=''>選択...</option></select>",
openLabel: "開く",
openPrompt: "このファイルあるいはサーバーへ接続する",
openError: "TiddlyWikiファイルを取り込む際に問題が発生しました",
statusOpenHost: "ホストをオープン中",
statusGetWorkspaceList: "有効なワークスペースのリストを取得中",
step2Title: "手順 2: ワークスペースの選択",
step2Html: "ワークスペース名を入力: <input type='text' size=50 name='txtWorkspace'><br>またはワークスペースを選択: <select name='selWorkspace'><option value=''>選択...</option></select>",
cancelLabel: "キャンセル",
cancelPrompt: "この取り込みをキャンセルする",
statusOpenWorkspace: "ワークスペースをオープン中",
statusGetTiddlerList: "有効なtiddlerのリストを取得中",
errorGettingTiddlerList: "tiddlerのリストを取得中にエラーが発生しました。'キャンセル'でやり直します。",
step3Title: "手順 3: 取り込むtiddlerの選択",
step3Html: "<input type='hidden' name='markList'></input><br><input type='checkbox' checked='true' name='chkSync'>変更を同期できるよう、各tiddlerにこのサーバー（ファイル）へのリンクを保持する</input><br><input type='checkbox' name='chkSave'>'systemServer' タグを付けたtiddlerにこのサーバーの詳細を保存する:</input> <input type='text' size=25 name='txtSaveTiddler'>",
importLabel: "取込",
importPrompt: "これらのtiddlerを取り込む",
confirmOverwriteText: "本当にこれらのtiddlerを上書きして良いですか? :\n\n%0",
step4Title: "手順 4: tiddler %0 を取り込み",
step4Html: "<input type='hidden' name='markReport'></input>", // DO NOT TRANSLATE
doneLabel: "完了",
donePrompt: "ウィザードを閉じる",
statusDoingImport: "tidderlを取り込み中",
statusDoneImport: "全てのtiddlerを取り込みました",
systemServerNamePattern: "%1 / %2",
systemServerNamePatternNoWorkspace: "%1",
confirmOverwriteSaveTiddler: "'%0' というtiddlerは既に存在します。'OK'で上書きします。'キャンセル'で変更しません。",
serverSaveTemplate: "|''種別:''|%0|\n|''URL:''|%1|\n|''ワークスペース:''|%2|\n\nこのtiddlerはこのサーバーの詳細情報を記録するために自動的に作成されました",
serverSaveModifier: "(System)",
listViewTemplate: {
columns: [
{name: 'Selected', field: 'Selected', rowName: 'title', type: 'Selector'},
{name: 'Tiddler', field: 'tiddler', title: "Tiddler", type: 'Tiddler'},
{name: 'Size', field: 'size', tiddlerLink: 'size', title: "サイズ", type: 'Size'},
{name: 'Tags', field: 'tags', title: "タグ", type: 'Tags'}
],
rowClasses: [
]}
});
merge(config.macros.upgrade,{
wizardTitle: "TiddlyWiki本体のアップグレード",
step1Title: "このTiddlyWikiを最新版へ更新（あるいは修復）",
step1Html: "TiddlyWiki本体のバージョンを <a href='%0' class='externalLink' target='_blank'>%1</a> から最新版に更新しようとしています。この更新をしてもあなたの作成したデータが削除されることはありません。<br><br>なお、本体をアップデートすることで旧プラグインの動作に支障が出る可能性があります。もし更新後の動作に問題が生じたときは、次のサイトを参照してください。<a href='http://www.tiddlywiki.org/wiki/CoreUpgrades' class='externalLink' target='_blank'>http://www.tiddlywiki.org/wiki/CoreUpgrades</a>",
errorCantUpgrade: "このTiddlyWikiを更新できませんでした。ローカルに保存したファイルにしか、TiddlyWikiの更新はできません。",
errorNotSaved: "更新を行う前にまずファイルを保存してください。",
step2Title: "更新作業の詳細を確認",
step2Html_downgrade: "TiddlyWikiのバージョンを %1 から %0 へダウングレードしようとしています。<br><br>TiddlyWiki本体を旧バージョンにダウングレードすることは推奨されません。",
step2Html_restore: "このTiddlyWikiはすでに最新版(%0)です。<br><br>もちろんTiddlyWiki本体が破損していたときなどのために、このまま更新を継続することもできます。",
step2Html_upgrade: "TiddlyWikiのバージョンを %1 から %0 に更新しようとしています。",
upgradeLabel: "更新",
upgradePrompt: "更新処理の準備",
statusPreparingBackup: "バックアップの準備中",
statusSavingBackup: "バックアップファイル保存中",
errorSavingBackup: "バックアップファイルの保存中にエラーが発生しました",
statusLoadingCore: "本体プログラムを読み込み中",
errorLoadingCore: "本体プログラムの読み込み中にエラーが発生しました",
errorCoreFormat: "新しいプログラムにエラーが発生しました",
statusSavingCore: "本体プログラムの保存中",
statusReloadingCore: "本体プログラムのリロード中",
startLabel: "開始",
startPrompt: "更新処理を開始する",
cancelLabel: "キャンセル",
cancelPrompt: "更新処理を中断する",
step3Title: "更新処理を中断",
step3Html: "更新処理を中断しました"
});
merge(config.macros.sync,{
listViewTemplate: {
columns: [
{name: 'Selected', field: 'selected', rowName: 'title', type: 'Selector'},
{name: 'Tiddler', field: 'tiddler', title: "Tiddler", type: 'Tiddler'},
{name: 'Server Type', field: 'serverType', title: "種別", type: 'String'},
{name: 'Server Host', field: 'serverHost', title: "サーバーホスト", type: 'String'},
{name: 'Server Workspace', field: 'serverWorkspace', title: "ワークスペース", type: 'String'},
{name: 'Status', field: 'status', title: "同期ステータス", type: 'String'},
{name: 'Server URL', field: 'serverUrl', title: "サーバーURL", text: "開く", type: 'Link'}
],
rowClasses: [
],
buttons: [
{caption: "これらのtiddlerを同期", name: 'sync'}
]},
wizardTitle: "外部サーバーやファイルとの同期",
step1Title: "同期したいtiddlerを選択してください",
step1Html: "<input type='hidden' name='markList'></input>", // DO NOT TRANSLATE
syncLabel: "同期",
syncPrompt: "各tiddlerを同期します",
hasChanged: "ローカル側変更あり",
hasNotChanged: "ローカル側変更なし",
syncStatusList: {
none: {text: "...", color: "transparent", display:null},
changedServer: {text: "サーバー側で変更あり", color: '#8080ff', display:null},
changedLocally: {text: "ローカル側で変更あり", color: '#80ff80', display:null},
changedBoth: {text: "双方で変更あり", color: '#ff8080', display:null},
notFound: {text: "サーバーに見つかりません", color: '#ffff80', display:null},
putToServer: {text: "更新をサーバーに保存しました", color: '#ff80ff', display:null},
gotFromServer: {text: "サーバーから更新を取得しました", color: '#80ffff', display:null}
}
});
merge(config.commands.closeTiddler,{
text: "閉じる",
tooltip: "このtiddlerを閉じます"});
merge(config.commands.closeOthers,{
text: "他を閉じる",
tooltip: "他の全てのtiddlerを閉じます"});
merge(config.commands.editTiddler,{
text: "編集",
tooltip: "このtiddlerを編集します",
readOnlyText: "閲覧",
readOnlyTooltip: "このtiddlerのソースを表示します"});
merge(config.commands.saveTiddler,{
text: "確定",
tooltip: "このtiddlerへの変更を保存します"});
merge(config.commands.cancelTiddler,{
text: "キャンセル",
tooltip: "このtiddlerへの変更を破棄します",
warning: "本当に '%0' の変更を破棄して良いですか?",
readOnlyText: "終了",
readOnlyTooltip: "このtiddlerを通常表示にします"});
merge(config.commands.deleteTiddler,{
text: "削除",
tooltip: "このtiddlerを削除します",
warning: "本当に '%0' を削除して良いですか?"});
merge(config.commands.permalink,{
text: "リンクURL",
tooltip: "このtiddlerへのURLをアドレス欄に生成します"});
merge(config.commands.references,{
text: "参照一覧",
tooltip: "このtiddlerへの参照を一覧表示します",
popupNone: "参照がありません"});
merge(config.commands.jump,{
text: "ジャンプ",
tooltip: "他に開いているtiddlerへジャンプ"});
merge(config.commands.syncing,{
text: "同期",
tooltip: "このtiddlerと外部のサーバー(ファイル)との同期を制御します",
currentlySyncing: "<div>現在の同期状態<br>種別: <span class='popupHighlight'>'%0'</span><br></"+"div><div>ホスト: <span class='popupHighlight'>%1</span></"+"div><br><div>ワークスペース: <span class='popupHighlight'>%2</span></"+"div>", // Note escaping of closing <div> tag
notCurrentlySyncing: "同期されていません",
captionUnSync: "このtiddlerの同期を停止",
chooseServer: "このtiddlerを次のサーバーと同期する:",
currServerMarker: "\u25cf ",
notCurrServerMarker: " "});
merge(config.commands.fields,{
text: "拡張情報",
tooltip: "このtiddlerの拡張情報を表示します",
emptyText: "このtiddlerには拡張情報がありません",
listViewTemplate: {
columns: [
{name: 'Field', field: 'field', title: "項目", type: 'String'},
{name: 'Value', field: 'value', title: "値", type: 'String'}
],
rowClasses: [
],
buttons: [
]}});
merge(config.shadowTiddlers,{
DefaultTiddlers: "[[TranslatedGettingStarted]]",
MainMenu: "[[TranslatedGettingStarted]]\n\n\n^^~TiddlyWiki version <<version>>\n(c) 2007 [[UnaMesa|http://www.unamesa.org/]]^^",
TranslatedGettingStarted: "この空の~TiddlyWikiを使い始めるにあたって、まずは以下のtiddlerを編集してください。:\n;SiteTitle & SiteSubtitle: \n:このサイトのタイトルおよびサブタイトル。この上に表示されています。<br>保存後はブラウザのタイトルバーにも表示されます。\n;MainMenu: \n:メニュー。たいていは左側に表示されています。\n;DefaultTiddlers: \n:ここにtiddlerの名前が書かれていると、この TiddlyWiki を開いたときに、<br>そのtiddlerが初期表示されます。\nあなたの名前(編集したtiddlerに表示されます): <<option txtUserName>>",
SiteTitle: "My TiddlyWiki",
SiteSubtitle: "a reusable non-linear personal web notebook",
SiteUrl: "http://www.tiddlywiki.com/",
OptionsPanel: "これらの~TiddlyWikiを制御する各オプションの設定は、使用中のブラウザに保存されます。\n\n署名として使用するあなたの名前を~WikiWord形式(例 JoeBloggs)で入力してください。\n<<option txtUserName>>\n\n<<option chkSaveBackups>> バックアップを保存\n<<option chkAutoSave>> 自動保存\n<<option chkRegExpSearch>> 正規表現で検索\n<<option chkCaseSensitiveSearch>> 検索で大文字小文字を区別\n<<option chkAnimate>> アニメーション\n\n----\n詳細設定 [[TranslatedAdvancedOptions|AdvancedOptions]]",
SideBarOptions: '<<search>><<closeAll>><<permaview>><<newTiddler>><<newJournal "YYYY年MM月DD日" "ジャーナル">><<saveChanges>><<slider chkSliderOptionsPanel OptionsPanel "オプション \u00bb" "TiddlyWiki の詳細設定">>',
SideBarTabs: '<<tabs txtMainTab "時系列" "更新時刻の降順" TabTimeline "全て" "全てのtiddler" TabAll "タグ別" "全てのタグ" TabTags "その他" "その他の一覧" TabMore>>',
TabMore: '<<tabs txtMoreTab "未作成" "リンクがあるのに存在しないtiddler" TabMoreMissing "孤立" "どこからもリンクされていないtiddler" TabMoreOrphans "隠し" "隠されているtiddler" TabMoreShadowed>>'});
merge(config.annotations,{
AdvancedOptions: "このtiddlerでは詳細オプションを設定できます",
ColorPalette: "この隠しtiddlerで設定された各値によって、この~TiddlyWikiでの色の枠組みが規定されます。",
DefaultTiddlers: "この隠しtiddlerに列挙された各tiddlerは、この~TiddlyWIkiを開くと同時に自動的に表示されます。",
EditTemplate: "この隠しtiddlerにあるHTMLテンプレートは、tiddler編集中の表示方法を決定します。",
GettingStarted: "この隠しtiddlerは基本的な使用方法を説明します。",
ImportTiddlers: "この隠しtiddlerは他のtiddlerの取り込み機能を提供します。",
MainMenu: "この隠しtiddlerの内容は「メインメニュー」に表示されます。画面左手に表示されます。",
MarkupPreHead: "この隠しtiddlerの内容は、このTiddlyWikiHTMLファイルの<head>セクション開始直後に挿入されます。",
MarkupPostHead: "この隠しtiddlerの内容は、このTiddlyWikiHTMLファイルの<head>セクション終了直前に挿入されます。",
MarkupPreBody: "この隠しtiddlerの内容は、このTiddlyWikiHTMLファイルの<body>セクション開始直後に挿入されます。",
MarkupPostBody: "この隠しtiddlerの内容は、このTiddlyWikiHTMLファイルのスクリプトブロック直後にある、<body>セクション終了直前に挿入されます。",
OptionsPanel: "この隠しtiddlerの内容は、右手のサイドバー内でスライド式のオプションパネルとして表示されます。",
PageTemplate: "この隠しtiddlerにあるHTMLテンプレートは、~TiddlyWiki全体のレイアウトを決定します。",
PluginManager: "この隠しtiddlerはプラグインマネージャ機能を提供します。",
SideBarOptions: "この隠しtiddlerの内容は右手のサイドバー内のオプションパネルとして表示されます。",
SideBarTabs: "この隠しtiddlerの内容は右手のサイドバー内にタブパネルとして表示されます。",
SiteSubtitle: "この隠しtiddlerはページのサブタイトルとして利用されます。",
SiteTitle: "この隠しtiddlerはページのメインタイトルとして利用されます。",
SiteUrl: "この隠しtiddlerには、このTiddlyWikiを公開する際のURLを指定する必要があります。",
StyleSheetColors: "この隠しtiddlerはページ内各要素の色に関するCSSを規定します。このtiddlerを編集しないでください。色を修正するには代わりに StyleSheet 隠しtiddler を編集してください。",
StyleSheet: "この隠しtiddlerはカスタムCSSを規定します。",
StyleSheetLayout: "この隠しtiddlerはページ内各要素のレイアウトに関するCSSを規定します。このtiddlerを編集しないでください。レイアウトを修正するには代わりに StyleSheet 隠しtiddler を編集してください。",
StyleSheetLocale: "この隠しtiddlerはページ内各要素の翻訳ロケールに関するCSSを規定します。",
StyleSheetPrint: "この隠しtiddlerは印刷に関するCSSを規定します。",
TabAll: "この隠しtiddlerの内容は右手のサイドバー内「全て」タブに表示されます。",
TabMore: "この隠しtiddlerの内容は右手のサイドバー内「その他」タブに表示されます。",
TabMoreMissing: "この隠しtiddlerの内容は右手のサイドバー内「未作成」タブに表示されます。",
TabMoreOrphans: "この隠しtiddlerの内容は右手のサイドバー内「孤立」タブに表示されます。",
TabMoreShadowed: "この隠しtiddlerの内容は右手のサイドバー内「隠し」タブに表示されます。",
TabTags: "この隠しtiddlerの内容は右手のサイドバー内「タグ別」タブに表示されます。",
TabTimeline: "この隠しtiddlerの内容は右手のサイドバー内「時系列」タブに表示されます。",
ToolbarCommands: "この隠しtiddlerはtiddlerツールバーにどのようなコマンドを表示するかを決定します。",
ViewTemplate: "この隠しtiddlerにあるHTMLテンプレートは、各tiddlerの表示方法を決定します。"
});
//}}}
/***
|''Name:''|LoadRemoteFileThroughProxy (previous LoadRemoteFileHijack)|
|''Description:''|When the TiddlyWiki file is located on the web (view over http) the content of [[SiteProxy]] tiddler is added in front of the file url. If [[SiteProxy]] does not exist "/proxy/" is added. |
|''Version:''|1.1.0|
|''Date:''|mar 17, 2007|
|''Source:''|http://tiddlywiki.bidix.info/#LoadRemoteFileHijack|
|''Author:''|BidiX (BidiX (at) bidix (dot) info)|
|''License:''|[[BSD open source license|http://tiddlywiki.bidix.info/#%5B%5BBSD%20open%20source%20license%5D%5D ]]|
|''~CoreVersion:''|2.2.0|
***/
//{{{
version.extensions.LoadRemoteFileThroughProxy = {
major: 1, minor: 1, revision: 0,
date: new Date("mar 17, 2007"),
source: "http://tiddlywiki.bidix.info/#LoadRemoteFileThroughProxy"};
if (!window.bidix) window.bidix = {}; // bidix namespace
if (!bidix.core) bidix.core = {};
bidix.core.loadRemoteFile = loadRemoteFile;
loadRemoteFile = function(url,callback,params)
{
if ((document.location.toString().substr(0,4) == "http") && (url.substr(0,4) == "http")){
url = store.getTiddlerText("SiteProxy", "/proxy/") + url;
}
return bidix.core.loadRemoteFile(url,callback,params);
}
//}}}
<<calendar thismonth>>
!Delphi関連
<<list filter "[tag[Delphi関連カテゴリ]]">>
!Windows関連
<<list filter "[tag[Windows関連カテゴリ]]">>
!Internet関連
<<list filter "[tag[Internet関連カテゴリ]]">>
----
[[WelcomeToTiddlyspot]] [[GettingStarted]]
プロジェクトのdprファイルのbegin 以下を変更
{{{
const
MutexName = 'MyMutexName'
var
hMutex : THandle;
begin
hMutex :=OpenMutex(MUTEX_ALL_ACCESS, false,MutexName );
try
if mu<>0 then
exit;
hMutex :=CreateMutex(nil, false, MutexName );
{従来のコード ここから}
Application.Initialize;
Application.CreateForm(TFormProcessLog, FormProcessLog);
Application.Run;
{従来のコード ここまで}
finally
CloseHandle( hMutex );
end;
end;
}}}
{{{
procedure getPop3InfoIndy(pop3: TIdPOP3);
var
option: string;
Login: TIdSASLLogin;
Provider: TIdUserPassProvider;
SSLHandler: TIdSSLIOHandlerSocketOpenSSL;
begin
pop3.Host := hi_str(nako_getVariable('メールホスト'));
pop3.Port := StrToIntDef(hi_str(nako_getVariable('メールポート')), 110);
pop3.Username := hi_str(nako_getVariable('メールID'));
pop3.Password := hi_str(nako_getVariable('メールパスワード'));
option := UpperCase(hi_str(nako_getVariable('メールオプション')));
pop3.AuthType := patUserPass;
if Pos('APOP',option) > 0 then
begin
pop3.AuthType := patAPOP;
end else
if Pos('SSL', option) > 0 then
begin
// IOHandler
SSLHandler := TIdSSLIOHandlerSocketOpenSSL.Create(pop3);
pop3.IOHandler := SSLHandler;
// POP3.AuthType := patSASL;
POP3.UseTLS := utUseImplicitTLS;
// Login & Provider
Login := TIdSASLLogin.Create(pop3);
Provider := TIdUserPassProvider.Create(Login);
Login.UserPassProvider := Provider;
Provider.Username := pop3.Username;
Provider.Password := pop3.Password;
end;
// CHECK
if pop3.Host = '' then raise Exception.Create('メールホストが空です。');
if pop3.Port <= 0 then raise Exception.Create('メールポートが不正な数値です。');
if pop3.Username = '' then raise Exception.Create('メールユーザーが空です。');
if pop3.Password = '' then raise Exception.Create('メールパスワードが空です。');
end;
}}}
/***
|''Name:''|PasswordOptionPlugin|
|''Description:''|Extends TiddlyWiki options with non encrypted password option.|
|''Version:''|1.0.2|
|''Date:''|Apr 19, 2007|
|''Source:''|http://tiddlywiki.bidix.info/#PasswordOptionPlugin|
|''Author:''|BidiX (BidiX (at) bidix (dot) info)|
|''License:''|[[BSD open source license|http://tiddlywiki.bidix.info/#%5B%5BBSD%20open%20source%20license%5D%5D ]]|
|''~CoreVersion:''|2.2.0 (Beta 5)|
***/
//{{{
version.extensions.PasswordOptionPlugin = {
major: 1, minor: 0, revision: 2,
date: new Date("Apr 19, 2007"),
source: 'http://tiddlywiki.bidix.info/#PasswordOptionPlugin',
author: 'BidiX (BidiX (at) bidix (dot) info',
license: '[[BSD open source license|http://tiddlywiki.bidix.info/#%5B%5BBSD%20open%20source%20license%5D%5D]]',
coreVersion: '2.2.0 (Beta 5)'
};
config.macros.option.passwordCheckboxLabel = "Save this password on this computer";
config.macros.option.passwordInputType = "password"; // password | text
setStylesheet(".pasOptionInput {width: 11em;}\n","passwordInputTypeStyle");
merge(config.macros.option.types, {
'pas': {
elementType: "input",
valueField: "value",
eventName: "onkeyup",
className: "pasOptionInput",
typeValue: config.macros.option.passwordInputType,
create: function(place,type,opt,className,desc) {
// password field
config.macros.option.genericCreate(place,'pas',opt,className,desc);
// checkbox linked with this password "save this password on this computer"
config.macros.option.genericCreate(place,'chk','chk'+opt,className,desc);
// text savePasswordCheckboxLabel
place.appendChild(document.createTextNode(config.macros.option.passwordCheckboxLabel));
},
onChange: config.macros.option.genericOnChange
}
});
merge(config.optionHandlers['chk'], {
get: function(name) {
// is there an option linked with this chk ?
var opt = name.substr(3);
if (config.options[opt])
saveOptionCookie(opt);
return config.options[name] ? "true" : "false";
}
});
merge(config.optionHandlers, {
'pas': {
get: function(name) {
if (config.options["chk"+name]) {
return encodeCookie(config.options[name].toString());
} else {
return "";
}
},
set: function(name,value) {config.options[name] = decodeCookie(value);}
}
});
// need to reload options to load passwordOptions
loadOptionsCookie();
/*
if (!config.options['pasPassword'])
config.options['pasPassword'] = '';
merge(config.optionsDesc,{
pasPassword: "Test password"
});
*/
//}}}
{{{
procedure getSmtpInfoIndy(smtp: TIdSMTP);
var
option: string;
Login : TIdSASLLogin;
Provider : TIdUserPassProvider;
SSLHandler: TIdSSLIOHandlerSocketOpenSSL;
begin
// サーバー情報
smtp.Host := hi_str(nako_getVariable('メールホスト'));
smtp.Port := StrToIntDef(hi_str(nako_getVariable('メールポート')), 25);
smtp.Username := hi_str(nako_getVariable('メールID'));
smtp.Password := hi_str(nako_getVariable('メールパスワード'));
// CHECK
if smtp.Host = '' then raise Exception.Create('メールホストが空です。');
// option
option := UpperCase(hi_str(nako_getVariable('メールオプション')));
if Pos('LOGIN', option) > 0 then smtp.AuthType := satDefault;
if Pos('PLAIN', option) > 0 then smtp.AuthType := satDefault;
if Pos('SSL', option) > 0 then
begin
Login := TIdSASLLogin.Create(SMTP);
Provider := TIdUserPassProvider.Create(Login);
Login.UserPassProvider := Provider;
Provider.Username := smtp.Username;
Provider.Password := smtp.Password;
SMTP.SASLMechanisms.Add.SASL := Login;
SMTP.AuthType := satSASL;
SSLHandler := TIdSSLIOHandlerSocketOpenSSL.Create(SMTP);
SMTP.IOHandler := SSLHandler; //TIdSSLIOHandlerSocketOpenSSL
//SMTP.UseTLS := utUseExplicitTLS; // Explict
SMTP.UseTLS := utUseImplicitTLS; // Explict
end;
end;
}}}
!POP before SMTP
POP3の認証を利用し、認証が行われたIPから定時間限定してSMTPによるメールの送信を許可する。
!SMTP Authentication(SMTP-AUTH)
ユーザアカウントとパスワードの認証を行うもの
以下の方式がある
*AUTH-LOGIN
*AUTH PLAIN
*AUTH CRAM-MD5 (パスワード暗号化付き)
#ドロップダウンリスト表示中の状態はDroppedDownプロパティで取得する。
#ドロップダウンリスト表示中に選択位置を変えた場合でもIteｍIndexのプロパティに影響する。
DrowItemメソッドをオーバーライドしたコントロールを作成する。
{{{
procedure TColorComboBox.DrawItem(Index: Integer; Rect: TRect;
State: TOwnerDrawState);
const
ArrowWidth = 6;
ArrowHeight = 12;
Space = 2;
begin
TControlCanvas(Canvas).UpdateTextFlags;
if Assigned(OnDrawItem) then
begin
OnDrawItem(Self, Index, Rect, State);
Exit;
end;
Canvas.Font .Color := Font.Color;
Canvas.Brush.Color := 背景色
Canvas.FillRect(Rect);
Canvas.TextOut(ArrowWidth + Space * 2 + 2, Rect.Top, Items[Index]);
if odSelected in State then
begin
Canvas.DrawFocusRect(Rect);
Canvas.Brush.Color := Font.Color;
Rect.Left := Rect.Left + Space;
Rect.Right := Rect.Left + ArrowWidth;
Rect.Top := Rect.Top + (Rect.Bottom - Rect.Top - ArrowHeight) div 2;
Rect.Bottom := Rect.Top + ArrowHeight;
Canvas.Polygon([Point(Rect.Left , Rect.Top),
Point(Rect.Right, (Rect.Top + Rect.Bottom) div 2),
Point(Rect.Left , Rect.Bottom),
Point(Rect.Left , Rect.Top)]);
end;
end;
}}}
TGraphiｃControlから継承したコンポーネントを作る場合は、以下のプロパティは必ず継承しましょう。
Publishedにプロパティ記述するだけで、コードを書かなくても使えます。
これにより、コンポーネントの配置を上下左右にあわせたり、基準位置を変更したりが自動でできます。
*Align
*Anchors
Labelに複数行の文字列を表示する方法です。
{{{
Label1.Caption:='1行目'+#13#10+'2行目';
}}}
これは、Form定義時に記述することはできません。（Delphi7）
そういう場合はTListを継承してしまいましょう。
type節に追加します
//{{{
uses
Classes;
type
TMyClassList = class(TList)
private
function Get(Index: Integer): TMyClass;
procedure Put(Index: Integer; const Value: TMyClass);
{private }
protected
procedure Notify(Ptr: Pointer;
Action: TListNotification); override;
{protected}
public
property Items[Index: Integer]: TMyClass read Get write Put; default;
{public}
end;
//}}}
実装部には
//{{{
{ TMyClassList }
function TMyClassList.Get(Index: Integer): TMyClass;
begin
Result := TMyClass( inherited Get(Index) );
end;
procedure TMyClassList.Put(Index: Integer; const Value: TMyClass);
begin
inherited Put( Index, Value );
end;
//}}}
TMyClassは適当に変えてください。
これだけで、TListを使うのとほとんど同様に
TMyClassList.Items[i].MyClassProperty
という風にスッキリと使えます。
また、TListを継承する時ついでに
//{{{
TMyClassList = class(TList)
public
destructor Destroy; override;
…
destructor TMyClassList.Destroy;
var
i: Integer;
begin
for i := 0 to Self.Count - 1 do
Self.Items[i].Free;
inherited Destroy;
end;
procedure TMyClassList.Notify(Ptr: Pointer;
Action: TListNotification);
var
a :
begin
if Action = lnDeleted then
begin
{Listから削除したときの処理}
TMyClass(Ptr).free;
Ptr := nil;
end;
if Action = lnAddedthen
begin
{Listに追加したときの処理}
；
end;
if Action = lnExtracted then
begin
{リストから抽出されたときの処理}
；
end;
inherited;
end;
//}}}
と実装しておくとListが破棄される時に
所有するItemも一緒に破棄されるので
結構便利に使えるでしょう。
----
ちなみに、DestroyとClearメソッドを定義すると、Destroyメソッドからクリアメソッドを読んでるので変になってしまう。
OnSetEditTextイベントで２回続けて同じ文字列なら確定にする。
こうすると、フォーカスの移動とか、ENTERキー確定もできる。
OnDrawCellイベントを定義して、以下のようにコードを記述する。
{{{
procedure Class.sgPanelInfoDrawCell(Sender: TObject; ACol,
ARow: Integer; Rect: TRect; State: TGridDrawState);
var
cmp : TStringGrid;
begin
if not ( Sender is TStringGrid ) then exit;
cmp := TStringGrid( Sender );
if ARow < cmp.FixedRows then exit;
if ACol < cmp.FixedCols then exit;
if ~ then
begin
// 色を変更する箇所
if cmp.Row = ARow then
begin
cmp.Canvas.Brush.Color := $00006000; // Active行
end else
begin
cmp.Canvas.Brush.Color := clLime;
end;
cmp.Canvas.FillRect(Rect); //背景色描画
cmp.Canvas.TextRect(Rect,
Rect.Left+2, Rect.Top+2, cmp.Cells[ACol, ARow]); // 文字描画
end;
end;
}}}
TStringGrid のCols、Rowsプロパティを使用すると列、行に一括アクセス可能。
たとえば
{{{
AGrid : TStringGrid;
sList : TStringList;
}}}
とあるとき、
{{{
AGrid.Rows[1].CommaText := sList.CommaText;
}}}
とすると、1行を一括して設定可能。
また、
{{{
AGrid.Cols[1].CommaText := sList.CommaText;
}}}
とすると、１列を一括で設定可能。
取り出しも、可能です。
タイトル行の設定などは
{{{
AGrid.Rows[0].CommaText := '"Title1","Title2","Title3"...';
}}}
とすると一括設定できて便利です。
カンマ区切りテキスト
は、
StringList.CommaTextを使用して処理可能
StringList.CommaText := .... で
StringList.Strings[0]...StringList.Strings[n]にカンマで区切った各文字が入ります。
また、逆に
StringList.Add( brabrabra ) を繰り返して、
StringListl.CommaTextを参照するとカンマ区切りテキストになっています。
注意：空白も区切り文字として使用されます。ただし、”などを使用してうまい事、整理されています。これにより、文字列の中にカンマや空白、”を入れてもOKになってる。
----
空白を無視した処理をしたい場合は、以下のように行う
{{{
procedure AnalysCommaText(
sList : TStringList; // 出力するStringList
s : string ); // 入力文字列
begin
//カンマの両側をダブルクオーテーションで囲む
s := StringReplace(s,',' , '","' ,[rfReplaceAll]);
//最初と最後に'"'を付ける("a","b"," ","c")
s := '"'+ s +'"';
//'""'を'" "'に置換(a","b"," ","c)
s := StringReplace(s, '""','" "', [rfReplaceAll]);
sList.CommaText := s;
end;
}}}
/***
Description: Contains the stuff you need to use Tiddlyspot
Note, you also need UploadPlugin, PasswordOptionPlugin and LoadRemoteFileThroughProxy
from http://tiddlywiki.bidix.info for a complete working Tiddlyspot site.
***/
//{{{
// edit this if you are migrating sites or retrofitting an existing TW
config.tiddlyspotSiteId = 'ttanaka';
// make it so you can by default see edit controls via http
config.options.chkHttpReadOnly = false;
window.readOnly = false; // make sure of it (for tw 2.2)
window.showBackstage = true; // show backstage too
// disable autosave in d3
if (window.location.protocol != "file:")
config.options.chkGTDLazyAutoSave = false;
// tweak shadow tiddlers to add upload button, password entry box etc
with (config.shadowTiddlers) {
SiteUrl = 'http://'+config.tiddlyspotSiteId+'.tiddlyspot.com';
SideBarOptions = SideBarOptions.replace(/(<<saveChanges>>)/,"$1<<tiddler TspotSidebar>>");
OptionsPanel = OptionsPanel.replace(/^/,"<<tiddler TspotOptions>>");
DefaultTiddlers = DefaultTiddlers.replace(/^/,"[[WelcomeToTiddlyspot]] ");
MainMenu = MainMenu.replace(/^/,"[[WelcomeToTiddlyspot]] ");
}
// create some shadow tiddler content
merge(config.shadowTiddlers,{
'WelcomeToTiddlyspot':[
"This document is a ~TiddlyWiki from tiddlyspot.com. A ~TiddlyWiki is an electronic notebook that is great for managing todo lists, personal information, and all sorts of things.",
"",
"@@font-weight:bold;font-size:1.3em;color:#444; //What now?// @@ Before you can save any changes, you need to enter your password in the form below. Then configure privacy and other site settings at your [[control panel|http://" + config.tiddlyspotSiteId + ".tiddlyspot.com/controlpanel]] (your control panel username is //" + config.tiddlyspotSiteId + "//).",
"<<tiddler TspotControls>>",
"See also GettingStarted.",
"",
"@@font-weight:bold;font-size:1.3em;color:#444; //Working online// @@ You can edit this ~TiddlyWiki right now, and save your changes using the \"save to web\" button in the column on the right.",
"",
"@@font-weight:bold;font-size:1.3em;color:#444; //Working offline// @@ A fully functioning copy of this ~TiddlyWiki can be saved onto your hard drive or USB stick. You can make changes and save them locally without being connected to the Internet. When you're ready to sync up again, just click \"upload\" and your ~TiddlyWiki will be saved back to tiddlyspot.com.",
"",
"@@font-weight:bold;font-size:1.3em;color:#444; //Help!// @@ Find out more about ~TiddlyWiki at [[TiddlyWiki.com|http://tiddlywiki.com]]. Also visit [[TiddlyWiki.org|http://tiddlywiki.org]] for documentation on learning and using ~TiddlyWiki. New users are especially welcome on the [[TiddlyWiki mailing list|http://groups.google.com/group/TiddlyWiki]], which is an excellent place to ask questions and get help. If you have a tiddlyspot related problem email [[tiddlyspot support|mailto:support@tiddlyspot.com]].",
"",
"@@font-weight:bold;font-size:1.3em;color:#444; //Enjoy :)// @@ We hope you like using your tiddlyspot.com site. Please email [[feedback@tiddlyspot.com|mailto:feedback@tiddlyspot.com]] with any comments or suggestions."
].join("\n"),
'TspotControls':[
"| tiddlyspot password:|<<option pasUploadPassword>>|",
"| site management:|<<upload http://" + config.tiddlyspotSiteId + ".tiddlyspot.com/store.cgi index.html . . " + config.tiddlyspotSiteId + ">>//(requires tiddlyspot password)//<br>[[control panel|http://" + config.tiddlyspotSiteId + ".tiddlyspot.com/controlpanel]], [[download (go offline)|http://" + config.tiddlyspotSiteId + ".tiddlyspot.com/download]]|",
"| links:|[[tiddlyspot.com|http://tiddlyspot.com/]], [[FAQs|http://faq.tiddlyspot.com/]], [[blog|http://tiddlyspot.blogspot.com/]], email [[support|mailto:support@tiddlyspot.com]] & [[feedback|mailto:feedback@tiddlyspot.com]], [[donate|http://tiddlyspot.com/?page=donate]]|"
].join("\n"),
'TspotSidebar':[
"<<upload http://" + config.tiddlyspotSiteId + ".tiddlyspot.com/store.cgi index.html . . " + config.tiddlyspotSiteId + ">><html><a href='http://" + config.tiddlyspotSiteId + ".tiddlyspot.com/download' class='button'>download</a></html>"
].join("\n"),
'TspotOptions':[
"tiddlyspot password:",
"<<option pasUploadPassword>>",
""
].join("\n")
});
//}}}
| !date | !user | !location | !storeUrl | !uploadDir | !toFilename | !backupdir | !origin |
| 17/02/2010 14:04:13 | ttanaka | [[/|http://ttanaka.tiddlyspot.com/]] | [[store.cgi|http://ttanaka.tiddlyspot.com/store.cgi]] | . | [[index.html | http://ttanaka.tiddlyspot.com/index.html]] | . |
| 16/03/2010 15:32:44 | ttanaka | [[/|http://ttanaka.tiddlyspot.com/]] | [[store.cgi|http://ttanaka.tiddlyspot.com/store.cgi]] | . | [[index.html | http://ttanaka.tiddlyspot.com/index.html]] | . |
| 16/04/2010 14:06:57 | ttanaka | [[/|http://ttanaka.tiddlyspot.com/]] | [[store.cgi|http://ttanaka.tiddlyspot.com/store.cgi]] | . | [[index.html | http://ttanaka.tiddlyspot.com/index.html]] | . | ok |
| 16/04/2010 14:07:28 | ttanaka | [[/|http://ttanaka.tiddlyspot.com/]] | [[store.cgi|http://ttanaka.tiddlyspot.com/store.cgi]] | . | [[index.html | http://ttanaka.tiddlyspot.com/index.html]] | . |
| 29/06/2010 12:38:06 | ttanaka | [[/|http://ttanaka.tiddlyspot.com/]] | [[store.cgi|http://ttanaka.tiddlyspot.com/store.cgi]] | . | [[index.html | http://ttanaka.tiddlyspot.com/index.html]] | . | ok |
| 29/06/2010 12:42:19 | ttanaka | [[/|http://ttanaka.tiddlyspot.com/]] | [[store.cgi|http://ttanaka.tiddlyspot.com/store.cgi]] | . | [[index.html | http://ttanaka.tiddlyspot.com/index.html]] | . | failed |
| 29/06/2010 12:43:01 | ttanaka | [[/|http://ttanaka.tiddlyspot.com/]] | [[store.cgi|http://ttanaka.tiddlyspot.com/store.cgi]] | . | [[index.html | http://ttanaka.tiddlyspot.com/index.html]] | . |
| 10/08/2010 12:59:31 | 氏名 | [[/|http://ttanaka.tiddlyspot.com/]] | [[store.cgi|http://ttanaka.tiddlyspot.com/store.cgi]] | . | [[index.html | http://ttanaka.tiddlyspot.com/index.html]] | . | failed |
| 10/08/2010 13:00:25 | 氏名 | [[/|http://ttanaka.tiddlyspot.com/]] | [[store.cgi|http://ttanaka.tiddlyspot.com/store.cgi]] | . | [[index.html | http://ttanaka.tiddlyspot.com/index.html]] | . |
| 17/08/2010 16:32:02 | 氏名 | [[/|http://ttanaka.tiddlyspot.com/]] | [[store.cgi|http://ttanaka.tiddlyspot.com/store.cgi]] | . | [[index.html | http://ttanaka.tiddlyspot.com/index.html]] | . |
/***
|''Name:''|UploadPlugin|
|''Description:''|Save to web a TiddlyWiki|
|''Version:''|4.1.3|
|''Date:''|Feb 24, 2008|
|''Source:''|http://tiddlywiki.bidix.info/#UploadPlugin|
|''Documentation:''|http://tiddlywiki.bidix.info/#UploadPluginDoc|
|''Author:''|BidiX (BidiX (at) bidix (dot) info)|
|''License:''|[[BSD open source license|http://tiddlywiki.bidix.info/#%5B%5BBSD%20open%20source%20license%5D%5D ]]|
|''~CoreVersion:''|2.2.0|
|''Requires:''|PasswordOptionPlugin|
***/
//{{{
version.extensions.UploadPlugin = {
major: 4, minor: 1, revision: 3,
date: new Date("Feb 24, 2008"),
source: 'http://tiddlywiki.bidix.info/#UploadPlugin',
author: 'BidiX (BidiX (at) bidix (dot) info',
coreVersion: '2.2.0'
};
//
// Environment
//
if (!window.bidix) window.bidix = {}; // bidix namespace
bidix.debugMode = false; // true to activate both in Plugin and UploadService
//
// Upload Macro
//
config.macros.upload = {
// default values
defaultBackupDir: '', //no backup
defaultStoreScript: "store.php",
defaultToFilename: "index.html",
defaultUploadDir: ".",
authenticateUser: true // UploadService Authenticate User
};
config.macros.upload.label = {
promptOption: "Save and Upload this TiddlyWiki with UploadOptions",
promptParamMacro: "Save and Upload this TiddlyWiki in %0",
saveLabel: "save to web",
saveToDisk: "save to disk",
uploadLabel: "upload"
};
config.macros.upload.messages = {
noStoreUrl: "No store URL in parmeters or options",
usernameOrPasswordMissing: "Username or password missing"
};
config.macros.upload.handler = function(place,macroName,params) {
if (readOnly)
return;
var label;
if (document.location.toString().substr(0,4) == "http")
label = this.label.saveLabel;
else
label = this.label.uploadLabel;
var prompt;
if (params[0]) {
prompt = this.label.promptParamMacro.toString().format([this.destFile(params[0],
(params[1] ? params[1]:bidix.basename(window.location.toString())), params[3])]);
} else {
prompt = this.label.promptOption;
}
createTiddlyButton(place, label, prompt, function() {config.macros.upload.action(params);}, null, null, this.accessKey);
};
config.macros.upload.action = function(params)
{
// for missing macro parameter set value from options
if (!params) params = {};
var storeUrl = params[0] ? params[0] : config.options.txtUploadStoreUrl;
var toFilename = params[1] ? params[1] : config.options.txtUploadFilename;
var backupDir = params[2] ? params[2] : config.options.txtUploadBackupDir;
var uploadDir = params[3] ? params[3] : config.options.txtUploadDir;
var username = params[4] ? params[4] : config.options.txtUploadUserName;
var password = config.options.pasUploadPassword; // for security reason no password as macro parameter
// for still missing parameter set default value
if ((!storeUrl) && (document.location.toString().substr(0,4) == "http"))
storeUrl = bidix.dirname(document.location.toString())+'/'+config.macros.upload.defaultStoreScript;
if (storeUrl.substr(0,4) != "http")
storeUrl = bidix.dirname(document.location.toString()) +'/'+ storeUrl;
if (!toFilename)
toFilename = bidix.basename(window.location.toString());
if (!toFilename)
toFilename = config.macros.upload.defaultToFilename;
if (!uploadDir)
uploadDir = config.macros.upload.defaultUploadDir;
if (!backupDir)
backupDir = config.macros.upload.defaultBackupDir;
// report error if still missing
if (!storeUrl) {
alert(config.macros.upload.messages.noStoreUrl);
clearMessage();
return false;
}
if (config.macros.upload.authenticateUser && (!username || !password)) {
alert(config.macros.upload.messages.usernameOrPasswordMissing);
clearMessage();
return false;
}
bidix.upload.uploadChanges(false,null,storeUrl, toFilename, uploadDir, backupDir, username, password);
return false;
};
config.macros.upload.destFile = function(storeUrl, toFilename, uploadDir)
{
if (!storeUrl)
return null;
var dest = bidix.dirname(storeUrl);
if (uploadDir && uploadDir != '.')
dest = dest + '/' + uploadDir;
dest = dest + '/' + toFilename;
return dest;
};
//
// uploadOptions Macro
//
config.macros.uploadOptions = {
handler: function(place,macroName,params) {
var wizard = new Wizard();
wizard.createWizard(place,this.wizardTitle);
wizard.addStep(this.step1Title,this.step1Html);
var markList = wizard.getElement("markList");
var listWrapper = document.createElement("div");
markList.parentNode.insertBefore(listWrapper,markList);
wizard.setValue("listWrapper",listWrapper);
this.refreshOptions(listWrapper,false);
var uploadCaption;
if (document.location.toString().substr(0,4) == "http")
uploadCaption = config.macros.upload.label.saveLabel;
else
uploadCaption = config.macros.upload.label.uploadLabel;
wizard.setButtons([
{caption: uploadCaption, tooltip: config.macros.upload.label.promptOption,
onClick: config.macros.upload.action},
{caption: this.cancelButton, tooltip: this.cancelButtonPrompt, onClick: this.onCancel}
]);
},
options: [
"txtUploadUserName",
"pasUploadPassword",
"txtUploadStoreUrl",
"txtUploadDir",
"txtUploadFilename",
"txtUploadBackupDir",
"chkUploadLog",
"txtUploadLogMaxLine"
],
refreshOptions: function(listWrapper) {
var opts = [];
for(i=0; i<this.options.length; i++) {
var opt = {};
opts.push();
opt.option = "";
n = this.options[i];
opt.name = n;
opt.lowlight = !config.optionsDesc[n];
opt.description = opt.lowlight ? this.unknownDescription : config.optionsDesc[n];
opts.push(opt);
}
var listview = ListView.create(listWrapper,opts,this.listViewTemplate);
for(n=0; n<opts.length; n++) {
var type = opts[n].name.substr(0,3);
var h = config.macros.option.types[type];
if (h && h.create) {
h.create(opts[n].colElements['option'],type,opts[n].name,opts[n].name,"no");
}
}
},
onCancel: function(e)
{
backstage.switchTab(null);
return false;
},
wizardTitle: "Upload with options",
step1Title: "These options are saved in cookies in your browser",
step1Html: "<input type='hidden' name='markList'></input><br>",
cancelButton: "Cancel",
cancelButtonPrompt: "Cancel prompt",
listViewTemplate: {
columns: [
{name: 'Description', field: 'description', title: "Description", type: 'WikiText'},
{name: 'Option', field: 'option', title: "Option", type: 'String'},
{name: 'Name', field: 'name', title: "Name", type: 'String'}
],
rowClasses: [
{className: 'lowlight', field: 'lowlight'}
]}
};
//
// upload functions
//
if (!bidix.upload) bidix.upload = {};
if (!bidix.upload.messages) bidix.upload.messages = {
//from saving
invalidFileError: "The original file '%0' does not appear to be a valid TiddlyWiki",
backupSaved: "Backup saved",
backupFailed: "Failed to upload backup file",
rssSaved: "RSS feed uploaded",
rssFailed: "Failed to upload RSS feed file",
emptySaved: "Empty template uploaded",
emptyFailed: "Failed to upload empty template file",
mainSaved: "Main TiddlyWiki file uploaded",
mainFailed: "Failed to upload main TiddlyWiki file. Your changes have not been saved",
//specific upload
loadOriginalHttpPostError: "Can't get original file",
aboutToSaveOnHttpPost: 'About to upload on %0 ...',
storePhpNotFound: "The store script '%0' was not found."
};
bidix.upload.uploadChanges = function(onlyIfDirty,tiddlers,storeUrl,toFilename,uploadDir,backupDir,username,password)
{
var callback = function(status,uploadParams,original,url,xhr) {
if (!status) {
displayMessage(bidix.upload.messages.loadOriginalHttpPostError);
return;
}
if (bidix.debugMode)
alert(original.substr(0,500)+"\n...");
// Locate the storeArea div's
var posDiv = locateStoreArea(original);
if((posDiv[0] == -1) || (posDiv[1] == -1)) {
alert(config.messages.invalidFileError.format([localPath]));
return;
}
bidix.upload.uploadRss(uploadParams,original,posDiv);
};
if(onlyIfDirty && !store.isDirty())
return;
clearMessage();
// save on localdisk ?
if (document.location.toString().substr(0,4) == "file") {
var path = document.location.toString();
var localPath = getLocalPath(path);
saveChanges();
}
// get original
var uploadParams = new Array(storeUrl,toFilename,uploadDir,backupDir,username,password);
var originalPath = document.location.toString();
// If url is a directory : add index.html
if (originalPath.charAt(originalPath.length-1) == "/")
originalPath = originalPath + "index.html";
var dest = config.macros.upload.destFile(storeUrl,toFilename,uploadDir);
var log = new bidix.UploadLog();
log.startUpload(storeUrl, dest, uploadDir, backupDir);
displayMessage(bidix.upload.messages.aboutToSaveOnHttpPost.format([dest]));
if (bidix.debugMode)
alert("about to execute Http - GET on "+originalPath);
var r = doHttp("GET",originalPath,null,null,username,password,callback,uploadParams,null);
if (typeof r == "string")
displayMessage(r);
return r;
};
bidix.upload.uploadRss = function(uploadParams,original,posDiv)
{
var callback = function(status,params,responseText,url,xhr) {
if(status) {
var destfile = responseText.substring(responseText.indexOf("destfile:")+9,responseText.indexOf("\n", responseText.indexOf("destfile:")));
displayMessage(bidix.upload.messages.rssSaved,bidix.dirname(url)+'/'+destfile);
bidix.upload.uploadMain(params[0],params[1],params[2]);
} else {
displayMessage(bidix.upload.messages.rssFailed);
}
};
// do uploadRss
if(config.options.chkGenerateAnRssFeed) {
var rssPath = uploadParams[1].substr(0,uploadParams[1].lastIndexOf(".")) + ".xml";
var rssUploadParams = new Array(uploadParams[0],rssPath,uploadParams[2],'',uploadParams[4],uploadParams[5]);
var rssString = generateRss();
// no UnicodeToUTF8 conversion needed when location is "file" !!!
if (document.location.toString().substr(0,4) != "file")
rssString = convertUnicodeToUTF8(rssString);
bidix.upload.httpUpload(rssUploadParams,rssString,callback,Array(uploadParams,original,posDiv));
} else {
bidix.upload.uploadMain(uploadParams,original,posDiv);
}
};
bidix.upload.uploadMain = function(uploadParams,original,posDiv)
{
var callback = function(status,params,responseText,url,xhr) {
var log = new bidix.UploadLog();
if(status) {
// if backupDir specified
if ((params[3]) && (responseText.indexOf("backupfile:") > -1)) {
var backupfile = responseText.substring(responseText.indexOf("backupfile:")+11,responseText.indexOf("\n", responseText.indexOf("backupfile:")));
displayMessage(bidix.upload.messages.backupSaved,bidix.dirname(url)+'/'+backupfile);
}
var destfile = responseText.substring(responseText.indexOf("destfile:")+9,responseText.indexOf("\n", responseText.indexOf("destfile:")));
displayMessage(bidix.upload.messages.mainSaved,bidix.dirname(url)+'/'+destfile);
store.setDirty(false);
log.endUpload("ok");
} else {
alert(bidix.upload.messages.mainFailed);
displayMessage(bidix.upload.messages.mainFailed);
log.endUpload("failed");
}
};
// do uploadMain
var revised = bidix.upload.updateOriginal(original,posDiv);
bidix.upload.httpUpload(uploadParams,revised,callback,uploadParams);
};
bidix.upload.httpUpload = function(uploadParams,data,callback,params)
{
var localCallback = function(status,params,responseText,url,xhr) {
url = (url.indexOf("nocache=") < 0 ? url : url.substring(0,url.indexOf("nocache=")-1));
if (xhr.status == 404)
alert(bidix.upload.messages.storePhpNotFound.format([url]));
if ((bidix.debugMode) || (responseText.indexOf("Debug mode") >= 0 )) {
alert(responseText);
if (responseText.indexOf("Debug mode") >= 0 )
responseText = responseText.substring(responseText.indexOf("\n\n")+2);
} else if (responseText.charAt(0) != '0')
alert(responseText);
if (responseText.charAt(0) != '0')
status = null;
callback(status,params,responseText,url,xhr);
};
// do httpUpload
var boundary = "---------------------------"+"AaB03x";
var uploadFormName = "UploadPlugin";
// compose headers data
var sheader = "";
sheader += "--" + boundary + "\r\nContent-disposition: form-data; name=\"";
sheader += uploadFormName +"\"\r\n\r\n";
sheader += "backupDir="+uploadParams[3] +
";user=" + uploadParams[4] +
";password=" + uploadParams[5] +
";uploaddir=" + uploadParams[2];
if (bidix.debugMode)
sheader += ";debug=1";
sheader += ";;\r\n";
sheader += "\r\n" + "--" + boundary + "\r\n";
sheader += "Content-disposition: form-data; name=\"userfile\"; filename=\""+uploadParams[1]+"\"\r\n";
sheader += "Content-Type: text/html;charset=UTF-8" + "\r\n";
sheader += "Content-Length: " + data.length + "\r\n\r\n";
// compose trailer data
var strailer = new String();
strailer = "\r\n--" + boundary + "--\r\n";
data = sheader + data + strailer;
if (bidix.debugMode) alert("about to execute Http - POST on "+uploadParams[0]+"\n with \n"+data.substr(0,500)+ " ... ");
var r = doHttp("POST",uploadParams[0],data,"multipart/form-data; ;charset=UTF-8; boundary="+boundary,uploadParams[4],uploadParams[5],localCallback,params,null);
if (typeof r == "string")
displayMessage(r);
return r;
};
// same as Saving's updateOriginal but without convertUnicodeToUTF8 calls
bidix.upload.updateOriginal = function(original, posDiv)
{
if (!posDiv)
posDiv = locateStoreArea(original);
if((posDiv[0] == -1) || (posDiv[1] == -1)) {
alert(config.messages.invalidFileError.format([localPath]));
return;
}
var revised = original.substr(0,posDiv[0] + startSaveArea.length) + "\n" +
store.allTiddlersAsHtml() + "\n" +
original.substr(posDiv[1]);
var newSiteTitle = getPageTitle().htmlEncode();
revised = revised.replaceChunk("<title"+">","</title"+">"," " + newSiteTitle + " ");
revised = updateMarkupBlock(revised,"PRE-HEAD","MarkupPreHead");
revised = updateMarkupBlock(revised,"POST-HEAD","MarkupPostHead");
revised = updateMarkupBlock(revised,"PRE-BODY","MarkupPreBody");
revised = updateMarkupBlock(revised,"POST-SCRIPT","MarkupPostBody");
return revised;
};
//
// UploadLog
//
// config.options.chkUploadLog :
// false : no logging
// true : logging
// config.options.txtUploadLogMaxLine :
// -1 : no limit
// 0 : no Log lines but UploadLog is still in place
// n : the last n lines are only kept
// NaN : no limit (-1)
bidix.UploadLog = function() {
if (!config.options.chkUploadLog)
return; // this.tiddler = null
this.tiddler = store.getTiddler("UploadLog");
if (!this.tiddler) {
this.tiddler = new Tiddler();
this.tiddler.title = "UploadLog";
this.tiddler.text = "| !date | !user | !location | !storeUrl | !uploadDir | !toFilename | !backupdir | !origin |";
this.tiddler.created = new Date();
this.tiddler.modifier = config.options.txtUserName;
this.tiddler.modified = new Date();
store.addTiddler(this.tiddler);
}
return this;
};
bidix.UploadLog.prototype.addText = function(text) {
if (!this.tiddler)
return;
// retrieve maxLine when we need it
var maxLine = parseInt(config.options.txtUploadLogMaxLine,10);
if (isNaN(maxLine))
maxLine = -1;
// add text
if (maxLine != 0)
this.tiddler.text = this.tiddler.text + text;
// Trunck to maxLine
if (maxLine >= 0) {
var textArray = this.tiddler.text.split('\n');
if (textArray.length > maxLine + 1)
textArray.splice(1,textArray.length-1-maxLine);
this.tiddler.text = textArray.join('\n');
}
// update tiddler fields
this.tiddler.modifier = config.options.txtUserName;
this.tiddler.modified = new Date();
store.addTiddler(this.tiddler);
// refresh and notifiy for immediate update
story.refreshTiddler(this.tiddler.title);
store.notify(this.tiddler.title, true);
};
bidix.UploadLog.prototype.startUpload = function(storeUrl, toFilename, uploadDir, backupDir) {
if (!this.tiddler)
return;
var now = new Date();
var text = "\n| ";
var filename = bidix.basename(document.location.toString());
if (!filename) filename = '/';
text += now.formatString("0DD/0MM/YYYY 0hh:0mm:0ss") +" | ";
text += config.options.txtUserName + " | ";
text += "[["+filename+"|"+location + "]] |";
text += " [[" + bidix.basename(storeUrl) + "|" + storeUrl + "]] | ";
text += uploadDir + " | ";
text += "[[" + bidix.basename(toFilename) + " | " +toFilename + "]] | ";
text += backupDir + " |";
this.addText(text);
};
bidix.UploadLog.prototype.endUpload = function(status) {
if (!this.tiddler)
return;
this.addText(" "+status+" |");
};
//
// Utilities
//
bidix.checkPlugin = function(plugin, major, minor, revision) {
var ext = version.extensions[plugin];
if (!
(ext &&
((ext.major > major) ||
((ext.major == major) && (ext.minor > minor)) ||
((ext.major == major) && (ext.minor == minor) && (ext.revision >= revision))))) {
// write error in PluginManager
if (pluginInfo)
pluginInfo.log.push("Requires " + plugin + " " + major + "." + minor + "." + revision);
eval(plugin); // generate an error : "Error: ReferenceError: xxxx is not defined"
}
};
bidix.dirname = function(filePath) {
if (!filePath)
return;
var lastpos;
if ((lastpos = filePath.lastIndexOf("/")) != -1) {
return filePath.substring(0, lastpos);
} else {
return filePath.substring(0, filePath.lastIndexOf("\\"));
}
};
bidix.basename = function(filePath) {
if (!filePath)
return;
var lastpos;
if ((lastpos = filePath.lastIndexOf("#")) != -1)
filePath = filePath.substring(0, lastpos);
if ((lastpos = filePath.lastIndexOf("/")) != -1) {
return filePath.substring(lastpos + 1);
} else
return filePath.substring(filePath.lastIndexOf("\\")+1);
};
bidix.initOption = function(name,value) {
if (!config.options[name])
config.options[name] = value;
};
//
// Initializations
//
// require PasswordOptionPlugin 1.0.1 or better
bidix.checkPlugin("PasswordOptionPlugin", 1, 0, 1);
// styleSheet
setStylesheet('.txtUploadStoreUrl, .txtUploadBackupDir, .txtUploadDir {width: 22em;}',"uploadPluginStyles");
//optionsDesc
merge(config.optionsDesc,{
txtUploadStoreUrl: "Url of the UploadService script (default: store.php)",
txtUploadFilename: "Filename of the uploaded file (default: in index.html)",
txtUploadDir: "Relative Directory where to store the file (default: . (downloadService directory))",
txtUploadBackupDir: "Relative Directory where to backup the file. If empty no backup. (default: ''(empty))",
txtUploadUserName: "Upload Username",
pasUploadPassword: "Upload Password",
chkUploadLog: "do Logging in UploadLog (default: true)",
txtUploadLogMaxLine: "Maximum of lines in UploadLog (default: 10)"
});
// Options Initializations
bidix.initOption('txtUploadStoreUrl','');
bidix.initOption('txtUploadFilename','');
bidix.initOption('txtUploadDir','');
bidix.initOption('txtUploadBackupDir','');
bidix.initOption('txtUploadUserName','');
bidix.initOption('pasUploadPassword','');
bidix.initOption('chkUploadLog',true);
bidix.initOption('txtUploadLogMaxLine','10');
// Backstage
merge(config.tasks,{
uploadOptions: {text: "upload", tooltip: "Change UploadOptions and Upload", content: '<<uploadOptions>>'}
});
config.backstageTasks.push("uploadOptions");
//}}}
Visible=falseにしているのに描画される。
通常Visble=falseにした場合は、そのコンポーネントのPaintメソッドなどの描画イベントに対応するメソッドが呼ばれなくなるだけです。この場合は、その背景のコンポーネントやフォームで描画が行われて、コンポーネントは見えなくなります。
このため、描画イベントに関係なく描画するコンポーネントを作るとVisibleの設定は無視されます。
This document is a ~TiddlyWiki from tiddlyspot.com. A ~TiddlyWiki is an electronic notebook that is great for managing todo lists, personal information, and all sorts of things.
@@font-weight:bold;font-size:1.3em;color:#444; //What now?// @@ Before you can save any changes, you need to enter your password in the form below. Then configure privacy and other site settings at your [[control panel|http://ttanaka.tiddlyspot.com/controlpanel]] (your control panel username is //ttanaka//).
<<tiddler TspotControls>>
See also GettingStarted.
@@font-weight:bold;font-size:1.3em;color:#444; //Working online// @@ You can edit this ~TiddlyWiki right now, and save your changes using the "save to web" button in the column on the right.
@@font-weight:bold;font-size:1.3em;color:#444; //Working offline// @@ A fully functioning copy of this ~TiddlyWiki can be saved onto your hard drive or USB stick. You can make changes and save them locally without being connected to the Internet. When you're ready to sync up again, just click "upload" and your ~TiddlyWiki will be saved back to tiddlyspot.com.
@@font-weight:bold;font-size:1.3em;color:#444; //Help!// @@ Find out more about ~TiddlyWiki at [[TiddlyWiki.com|http://tiddlywiki.com]]. Also visit [[TiddlyWiki.org|http://tiddlywiki.org]] for documentation on learning and using ~TiddlyWiki. New users are especially welcome on the [[TiddlyWiki mailing list|http://groups.google.com/group/TiddlyWiki]], which is an excellent place to ask questions and get help. If you have a tiddlyspot related problem email [[tiddlyspot support|mailto:support@tiddlyspot.com]].
@@font-weight:bold;font-size:1.3em;color:#444; //Enjoy :)// @@ We hope you like using your tiddlyspot.com site. Please email [[feedback@tiddlyspot.com|mailto:feedback@tiddlyspot.com]] with any comments or suggestions.
コントロールパネルの「ユーザーとパスワード」を開き、
「ユーザー」タブページの
「「ユーザーがこのコンピュータを使うには、ユーザー名とパスワードの入力が必要」チェックボックスを外す。
<<list filter "[tag[DelphiWindowsAPI]]">>
<<list filter "[tag[MSWinSystsmTune]]">>
----
画面に合わせてWindowサイズを調整
Screen変数を使用して、WidthやHeightなどを貰う。
!Marlett
Window右上にある 「最小化」「最大化」「元のサイズ」「終了」ボタンなどは、
フォント「Marlett」にはいています。他にスクロールバー上下左右のボタン等も入っています。
----
Indy9用（POP before SMTP）
日本語使うときはjconvertが必要だったはず。
{{{
procedure TForm1.Button1Click(Sender: TObject);
var
IdSMTP: TIdSMTP;
IdPOP3: TIdPOP3;
host, subject, mailto, from, body:String;
begin
IdPOP3 := TIdPOP3.Create(nil);
IdPOP3.Host := 'pop.mail.yahoo.co.jp';
IdPOP3.Username := 'xxxx'; //ユーザー名
IdPOP3.Password := 'xxxx'; //パスワード
IdPOP3.Connect;
IdPOP3.Free;
IdSMTP := TIdSMTP.Create(nil);
IdSMTP.Port := 587;
IdSMTP.Host := 'smtp.mail.yahoo.co.jp';
IdSMTP.Username := 'xxxx'; //ユーザー名
IdSMTP.Password := 'xxxx'; //パスワード
host := 'smtp.mail.yahoo.co.jp';
subject := 'test';
mailto := 'xxx@xxx.xxx'; //送り先
from := 'xxxx@yahoo.co.jp'; //送り主
body := 'メール本文';
IdSMTP.QuickSend(host, subject, mailto, from, body);
IdSMTP.Free;
end;
}}}
私もYahooBBです。
■SMTP-AUTHを利用
{{{
procedure TForm1.Button3Click(Sender: TObject);
var
IdSMTP: TIdSMTP;
host, subject, mailto, from, body:String;
begin
IdSMTP := TIdSMTP.Create(nil);
IdSMTP.Port := 587;
IdSMTP.Host := 'smtp.mail.yahoo.co.jp';
IdSMTP.AuthType := atSASL; //追加
IdSMTP.Username := 'xxxxxxxx'; //ユーザー名
IdSMTP.Password := 'xxxxxxxx'; //パスワード
host := 'smtp.mail.yahoo.co.jp';
subject := 'タイトル;
mailto := 'xxx@xxxx.xxxx'; //送り先
from := 'xxxxxxxx@yahoo.co.jp'; //送り主
body := 'メール本文';
IdSMTP.QuickSend(host, subject, mailto, from, body);
IdSMTP.Free;
end;
}}}
Delphiの If ～ then ～ else のコーディングで注意事項があります。
【正常な例】
{{{
if Data = 1 then
SharedmemPutValue('D',Address,1)
else
SharedmemPutValue('D',Address,2);
【不具合事例】 begin end を使用しないで複数個を判断する処理
if Data = 1 then
SharedmemPutValue('D',Address,1)
else
if Data = 2 then
SharedmemPutValue('D',Address,2)
else
if Data = 3 then
SharedmemPutValue('D',Address,3)
else
if Data = 4 then
SharedmemPutValue('D',Address,4);
}}}
この場合、最初の Data=1 の条件時のみ実行され、その他は無視されてしまいま
す。
ついやりがちな処理です。注意してください。
（なにやら納得できないところもありますが、Delphiコーディング規約に記入
されているとのことです。）
【不具合修正例】
{{{
if Data = 1 then
begin
SharedmemPutValue('D',Address,1)
end
else
if Data = 2 then
begin
SharedmemPutValue('D',Address,2)
end
else
if Data = 3 then
begin
SharedmemPutValue('D',Address,3)
end
else
if Data = 4 then
begin
SharedmemPutValue('D',Address,4)
end
}}}
たとえば、文字cが数字かどうかを判定する場合は、
{{{
if c in ['0'..'9'] then
begin
...
end;
}}}
という感じで判断可能。
たとえば、文字cが数字またはアルファベットかをチェックしたいなら、
{{{
if c in ['0'..'9','a'..'z','A'..'Z'] then
begin
...
end;
}}}
でOK
Classの種類をチェックするのに使用します。
イベント処理などでは、Senderがどのコンポーネントかのチェックが必要な場合があります。特定クラスだけであれば
{{{
procedure MyClass.ItemClick( Sender : TObject );
begin
if Sender.ClassName <> 'TButton' then exit;
...
end;
}}}
でも良いですが、ある程度汎用的に作るのであれば、特定クラスの継承であるかをチェックする必要があります。
この場合は以下のように記述します。
{{{
procedure MyClass.ItemClick( Sender : TObject );
begin
if not ( Sender is TButton ) then exit;
...
end;
}}}
strtoint で16進数
$xxxxで１６進数になる
unitの記述
{{{
unit Unit1;
interface
... 定義宣言を書く
implementation
... 定義を書く
... 実際に動くソースを書く
end.
}}}
SetErrorModeを使用する。
{{{
var
OldErrorMode : integer;
..
begin
..
OldErrorMode := SetErrorMode( SEM_FAILCRITICALERRORS );
try
...
{この間メッセージが抑制される}
...
finally
SetErrorMode( OldErrorMode );
end;
}}}
106ではCTRL+SHIFT+カタカナ／ひらがな
NEC PC-9800 シリーズ、東芝 カナ キー
106 日本語 Ctrl + ↑Shift + カタカナ ひらがな キー
106 日本語（ Ctrl + 英数） Ctrl + 英数 キー
101 英語 Shift + Ctrl + CapsLock キー
IBM PS/55 5576-002/003 Ctrl + 漢字 カタカナ キー
IBM PS/55 5576-001 Ctrl + カタカナ キー
AX 日本語 Ctrl + Shift + 英数カナ キー
106キーでは、IMEで日本語入力中は
Alt+カタカナ ひらがな キーで
ローマ字入力、カタカナ入力を切り替えられる。
以下のように宣言するとコンパイルでエラーがでる。
{{{
type
TMyData = class( TObject )
private
{}
ParentForm : TMyForm; ←ここでエラー
public
{}
end;
TMyForm = class( TForm )
...
}}}
この場合、以下のように宣言する。
{{{
type
TMyForm = class; ←これを追加
TMyData = class( TObject )
private
{}
ParentForm : TMyForm;
public
{}
end;
TMyForm = class( TForm )
...
}}}
あらかじめクラス名称を定義しておくことで、
正常にビルドできる。
クラス（オブジェクト）を引数として渡す場合、無条件にポインタ渡しになっているので、VarやOut指定する必要なし。
コントロールの作成方法
３段階に分けて作成する。
１段階目＝プロパティの設定によって描画を変更するコントロール
２段階目＝１段階目を継承し、操作関連の定義を行う
３段階目＝２段階目を継承し、アドレス割付、
インターフェースなどを追加して、実際の信号との関連付けや表示更新の動作を定義する。
要するにコンポーネント＝ポインタといって良い
コンポーネントはポインタを使用して実装しているってこと。
コンポーネントは、Delphiのクラスを使用して実装している
んで、クラスとは、イコール構造体のことで、ポインタをNew、Createして実装する。
ってことだから、結果的にコンポーネント＝ポインタということになり
{{{
TLabel a,b;
b = TLabel.Create(..);
a = b;
}}}
の a = bはポインタのコピーであるということです。
＜コンポーネントの場合＞
{{{
procedure TForm1.Button3Click(Sender: TObject);
var
Timer: TTimer;
begin
Timer := TTimer.Create(Self); //TTimer作成
Timer.Enabled := False;
Timer.OnTimer := MyTimer;
Form1.Tag := integer(Timer); //TagにTimerのポインタを代入
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
TTimer(Pointer(Form1.Tag)).Enabled := True; //TagをTTimerにキャスト
end;
procedure TForm1.MyTimer(Sender: TObject);
begin
Label1.Caption := DateTimeToStr(Now);
end;
}}}
例としてTTimerを作成してTagへ入れてみた。実は、コンポーネントはそれ自体がポインタである。そのため、コンポーネント変数は、ポインタと同様に扱うことができる。
このため、コンポーネントのポインタを使用して、そこのポインタを使用している例が多いが、あまり意味がなく、本当はコンポーネントの定義のみでOK
コンポーネントを入れる場合は、コンポーネントをCreateする。同時にメモリが確保されるため、別途Newする必要はない。コンポーネントはポインタなので、直接integerでキャストしてTagへ入れる。
コンポーネントを取り出す場合は、TagをPointer型でキャストする。コンポーネントはポインタなので、逆参照の必要はなく、そのままTTimerでキャストすればアクセスできるようになる。
コントロールの場合はメモリの解放は、フォームがしてくれるので（CreateしたときのAOwnerをフォームにする必要アリ）、特に何も記述しなくてよい。
コンポーネントパレットのアイコン
については
ImageEditorで
1.unit名をファイル名に 拡張子は.dcr
2.コンポーネント名のビットマップ
を作成します。
で、ソース内には
{$R *.dcr} を
implementationと uses定義の後に記述します。
この状態でコンパイル or 構築 して インストールするとアイコンに反映されます。
ヘルプの「パレットビットマップを参照してください。」
<<list filter "[tag[ComponentDesign]]">>
TFormのクラスのメンバとして定義したフォームのクラスは、そのフォームを破棄するときに自動的に破棄されます。
これは、FormDestroyを呼ぶ前に行われますので、TFormクラスのfreeは不要です。もし行うと、一般保護が発生します。
ただし、動作の途中で破棄を行うのは問題無しです。このときは、メンバをnilにするのを忘れてはいけません。NIL にしないと、フォームを破棄するときにfree使用とするが、既に破棄されているために例外が発生します。
----
例：
{{{
...
TMyForm = class( TForm )
...
MyLabel1 : TLabel;
...
procedure TMyForm.FormCreate;
..
MyLabel1 := nil; ←忘れると、Destroy時に初期化されていない値で開放されて例外発生
..
end;
procedure TMyForm.CreateLabel;
..
MyLabel1 := TLabel.Create( Self );
..
end;
...
procedure TMyForm.FreeLabel;
..
MyLabel1.free;
MyLabel1 := nil; ←忘れると、Destroy時に初期化されていない値で開放されて例外発生
..
end;
procedure TMyForm.FormDestroy;
..
//MyLabel1.free; ←消さないと、開放済みのクラスを2重に解放することになり、
例外発生
..
end;
}}}
{{{
uses SysUtils;
// 空白があるデータをダブルクオーテーションで囲む
s := StringReplace(s,',' , '","' ,[rfReplaceAll]);
// 最初と最後に'"'を付ける("a","b"," ","c")
s := '"'+ s +'"';
// '""'を'" "'に置換(a","b"," ","c)
s := StringReplace(s, '""','" "', [rfReplaceAll]);
TmpStringList.CommaText := s;
}}}
[[マルチスレッドの基本的な意味]]
[[事例：一秒周期の表示更新]]
[[事例：同時動作]]
[[事例：ログ収集とかでタイマ精度を考える場合]]
<<list filter "[tag[DelphiTips]]">>
<<list filter "[tag[NetworkProgramming]]">>
パッケージの再構築
Delphi5では、パッケージの再構築をする場合
パッケージのプロジェクト画面から、一番上の「Contains」を選択した状態で、
右クリックし、コンテキストメニューの「構築」を選択することで再構築が出来ます。
尚、再構築を行った場合は、インストールも再度行う必要があります。
ファイル名のドライブ名やディレクトリ名を取り出すなどの変換はSysUtilsユニットのライブラリ関数が使用できます。
|関数名|機能|
|ExtractFileDir|ドライブ名とディレクトリを取得|
|ExtractFilePath|ドライブ名とディレクトリを取得(最後に￥がつく)|
|ExtractFilename|ドライブ名、ディレクトリを除くファイル名|
|ExtractFileExt|拡張子|
|ExtractFileDrive|ドライブ名 ドライブレター+:|
|ExpandFilename|相対パスを絶対パスに|
|ExpandUNCFilename|UNCファイル名に変換|
|IncludeTrailingPathDelimiter|最後に\がつくようにする|
|ExcludeTrailingPathDelimiter|最後に\がつかないようにする|
フラットなパネル
領域だけ決めたパネルを作る場合
TPanel のコンテナ コンポーネントを使い
BevelInnerとBevelOuter を ｂｖNoneにする。
すると、背景と区別の無いパネルが作成できる
マルチスレッドの基本的な意味
1個のプログラム内で、複数のプログラムが同時に実行されること
マルチタスクの一種
小規模マイコン等では、これをマルチタスクと呼ぶ
Windowsやunixなどのマルチタスク環境では、複数のアプリケーションを同時に実行可能であるという意味でのマルチタスクと区別される。
実際には、プログラマの労力を減らす手法のひとつであり、以下の利点がある。
１．分散した開発
２．実仕様とソースの対比をしやすくする
参考書などではレスポンスをあげると書かれているが、これはマルチスレッドでコードを作成することにより、自動的に動作が動作が切り替えて動くことにより、重いスレッドがあっても、軽いスレッドはそれに関係なく応答することができる。
ファイルコピー中のキャンセルボタンがその例。
＊スレッド（Thread）の意味
細い線,糸,繊維,(糸のように)細いもの,筋道,寿命
> Borland Developer Networkのサイトの下記のURLに首題のタイトルでためになる
> 記事があります。
> 同じ名前のユニット名"MemCheck.pas"がありますが、BDNの記事で紹介している
> ものの方がより緻密で使い易いと私は思いました。
> メモリリークで困っているひとは試してみては如何でしょうか。
> （メモリリークチェック後、設定を元に戻して再コンパイルすることを忘れずに）
> URL：
> http://bdn.borland.com/article/33696
>
----
{{{
(*
MemCheck: the ultimate memory troubles hunter
Created by: Jean Marc Eber & Vincent Mahon, Soci騁・G駭駻ale, INFI/SGOP/R&D
Version 2.73 -> Also update OutputFileHeader when changing the version #
Contact...
Vincent.Mahon@free.fr
http://v.mahon.free.fr/pro/freeware/memcheck
Mail address:
Tour Soci騁・G駭駻ale
Sgib/Sgop/R&D
92987 Paris - La D馭ense cedex
France
Copyrights...
The authors grant you the right to modify/change the source code as long as the original authors are mentionned.
Please let us know if you make any improvements, so that we can keep an up to date version. We also welcome
all comments, preferably by email.
Portions of this file (all the code dealing with TD32 debug information) where derived from the following work, with permission.
Reuse of this code in a commercial application is not permitted. The portions are identified by a copyright notice.
> DumpFB.C Borland 32-bit Turbo Debugger dumper (FB09 & FB0A)
> Clive Turvey, Electronics Engineer, July 1998
> Copyright (C) Tenth Planet Software Intl., Clive Turvey 1998. All rights reserved.
> Clive Turvey <clive@tbcnet.com> http://www.tbcnet.com/~clive/vcomwinp.html
Disclaimer...
You use MemCheck at your own risks. This means that you cannot hold the authors or Soci騁・G駭駻ale to be
responsible for any software\hardware problems you may encounter while using this module.
General information...
MemCheck replaces Delphi's memory manager with a home made one. This one logs information each time memory is
allocated, reallocated or freed. When the program ends, information about memory problems is provided in a log file
and exceptions are raised at problematic points.
Basic use...
Set the MemCheckLogFileName option. Call MemChk when you want to start the memory monitoring. Nothing else to do !
When your program terminates and the finalization is executed, MemCheck will report the problems. This is the
behaviour you'll obtain if you change no option in MemCheck.
Features...
- List of memory spaces not deallocated, and raising of EMemoryLeak exception at the exact place in the source code
- Call stack at allocation time. User chooses to see or not to see this call stack at run time (using ShowCallStack),
when a EMemoryLeak is raised.
- Tracking of virtual method calls after object's destruction (we change the VMT of objects when they are destroyed)
- Tracking of method calls on an interface while the object attached to the interface has been destroyed
- Checking of writes beyond end of allocated blocks (we put a marker at the end of a block on allocation)
- Fill freed block with a byte (this allows for example to set fields of classes to Nil, or buffers to $FF, or whatever)
- Detect writes in deallocated blocks (we do this by not really deallocating block, and checking them on end - this
can be time consuming)
- Statistics collection about objects allocation (how many objects of a given class are created ?)
- Time stamps can be indicated and will appear in the output
Options and parameters...
- You can specify the log files names (MemCheckLogFileName)
- It is possible to tell MemCheck that you are instanciating an object in a special way - See doc for
CheckForceAllocatedType
- Clients can specify the depth of the call stack they want to store (StoredCallStackDepth)
Warnings...
- MemCheck is based on a lot of low-level hacks. Some parts of it will not work on other versions of Delphi
without being revisited (as soon as System has been recompiled, MemCheck is very likely to behave strangely,
because for example the address of InitContext will be bad).
- Some debugging tools exploit the map file to return source location information. We chose not to do that, because
we think the way MemCheck raises exceptions at the good places is better. It is still possible to use "find error"
in Delphi.
- Memcheck is not able to report accurate call stack information about a leak of a class which does not redefine
its constructor. For example, if an instance of TStringList is never deallocated, the call stack MemCheck will
report is not very complete. However, the leak is correctly reported by MemCheck.
A word about uses...
Since leaks are reported on end of execution (finalization of this unit), we need as many finalizations to occur
before memcheck's, so that if some memory is freed in these finalizations, it is not erroneously reported as leak. In order to
finalize MemCheck as late as possible, we use a trick to change the order of the list of finalizations.
Other memory managing products which are available (found easily on the internet) do not have this
problem because they just rely on putting the unit first in the DPR; but this is not safe without a build all.
In MemCheck we absolutely need to use two units: SysUtils and Windows.
Then, I decided in MemCheck 2.54 to use the unit Classes because I think it will lead to much simpler code.
We also use two units which we can use without risk since they dont have a finalization: Math and SyncObjs.
An analysis of the uses clauses of these five units shows that in fact MemCheck uses indirectly the following units:
Math, Classes, Typinfo, Consts, Variants, VaRUtils, SysUtils, ActiveX, Messages, SysConst, Windows, SyncObjs, System, SysInit and Types.
Of these, only Classes, Variants, System and SysUtils have a finalization section. I checked and it is not possible to have a leak
reported by MemCheck which is not correct because the memory would have been freed by one of these finalizations.
In the procedure ChangeFinalizationsOrder I make sure that only these four units are finalized after MemCheck (I could have decided for
the fifteen, but this would be more work, and I know it is useless).
*)
unit MemCheck;
{$A+}
{$H+}
{$IFDEF VER170}
//VER170 = Delphi 2005 for Win32
//Don't define DELPHI71_OR_LATER for Delphi 2005 for Win32.
{$UNDEF DELPHI71_OR_LATER}
{$DEFINE DELPHI6_OR_LATER}
{$DEFINE DELPHI7_OR_LATER}
{$ENDIF}
{$IFDEF VER150}
{$IFNDEF DELPHI70_MODE}
{$DEFINE DELPHI71_OR_LATER}
//If you are using Delphi 7.0 (not 7.1), then specify DELPHI70_MODE symbol in "Project/Options/Conditional defines" - Delphi 7.1 has build no. 4.453
{$ENDIF}
{$DEFINE DELPHI7_OR_LATER}
{$DEFINE DELPHI6_OR_LATER}
{$WARNINGS OFF} //We probably don't want to hear about warnings - Not sure about that
{$ENDIF}
{$IFDEF VER140}
{$DEFINE DELPHI6_OR_LATER}
{$ENDIF}
{$IFDEF DELPHI6_OR_LATER}
{$WARN UNIT_PLATFORM OFF} //NOT certified for Kylix
{$WARN SYMBOL_PLATFORM OFF}
{$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}
interface
procedure MemChk;
{Activates MemCheck and resets the allocated blocks stack.
Warning: the old stack is lost ! - It is the client's duty to commit the
releasable blocks by calling CommitReleases(AllocatedBlocks)}
procedure UnMemChk;
{sets back the memory manager that was installed before MemChk was called
If MemCheck is not active, this does not matter. The default delphi memory manager is set.
You should be very careful about calling this routine and know exactly what it does (see the FAQ on the web site)}
procedure CommitReleases;
{really releases the blocks}
procedure AddTimeStampInformation(const I: string);
{Logs the given information as associated with the current time stamp
Requires that MemCheck is active}
procedure LogSevereExceptions(const WithVersionInfo: string);
{Activates the exception logger}
function MemoryBlockCorrupted(P: Pointer): Boolean;
{Is the given block bad ?
P is a block you may for example have created with GetMem, or P can be an object.
Bad means you have written beyond the block's allocated space or the memory for this object was freed.
If P was allocated before MemCheck was launched, we return False}
function BlockAllocationAddress(P: Pointer): Pointer;
{The address at which P was allocated
If MemCheck was not running when P was allocated (ie we do not find our magic number), we return $00000000}
function IsMemCheckActive: boolean;
{Is MemCheck currently running ?
ie, is the current memory manager memcheck's ?}
function TextualDebugInfoForAddress(const TheAddress: Cardinal): string;
var
MemCheckLogFileName: string = ''; //The file memcheck will log information to
DeallocateFreedMemoryWhenBlockBiggerThan: Integer = 0;
{should blocks be really deallocated when FreeMem is called ? If you want all blocks to be deallocated, set this
constant to 0. If you want blocks to be never deallocated, set the cstte to MaxInt. When blocks are not deallocated,
MemCheck can give information about when the second deallocation occured}
ShowLogFileWhenUseful: Boolean = True;
const
StoredCallStackDepth = 26;
{Size of the call stack we store when GetMem is called, must be an EVEN number}
type
TCallStack = array[0..StoredCallStackDepth] of Pointer;
procedure FillCallStack(var St: TCallStack; const NbLevelsToExclude: integer);
//Fills St with the call stack
function CallStackTextualRepresentation(const S: TCallStack; const LineHeader: string): string;
//Will contain CR/LFs
implementation
uses
Windows, {Windows has no finalization, so is OK to use with no care}
Classes,
Math,
SyncObjs,
{$IFDEF USE_JEDI_JCL}JclDebug,{$ENDIF}
{$IFDEF DELPHI6_OR_LATER}Variants,{$ENDIF}
SysUtils; {Because of this uses, SysUtils must be finalized after MemCheck - Which is necessary anyway because SysUtils calls DoneExceptions in its finalization}
type
TKindOfMemory = (MClass, MUser, MReallocedUser);
{MClass means the block carries an object
MUser means the block is a buffer of unknown type (in fact we just know this is not an object)
MReallocedUser means this block was reallocated}
const
NoDebugInfo = '(no debug info)';
MemCheckLogFileNameSuffix = '_MemCheck.log';
(**************** MEMCHECK OPTIONS ********************)
DanglingInterfacesVerified = False;
{When an object is destroyed, should we fill the interface VMT with a special value which
will allow tracking of calls to this interface after the object was destroyed - This incompatible with CheckWipedBlocksOnTermination, so you have to choose}
WipeOutMemoryOnFreeMem = True;
{This is about what is done on memory freeing:
- for objects, this option replaces the VMT with a special one which will raise exceptions if a virtual method is called
- for other memory kinds, this will fill the memory space with the char below}
CharToUseToWipeOut: char = #0;
//I choose #0 because this makes objet fields Nil, which is easier to debug. Tell me if you have a better idea !
CheckWipedBlocksOnTermination = True and WipeOutMemoryOnFreeMem and not (DanglingInterfacesVerified);
{When iterating on the blocks (in OutputAllocatedBlocks), we check for every block which has been deallocated that it is still
filled with CharToUseToWipeOut.
Warning: this is VERY time-consuming
This is meaningful only when the blocks are wiped out on free mem
This is incompatible with dangling interfaces checking}
DoNotCheckWipedBlocksBiggerThan = 4000;
CollectStatsAboutObjectAllocation = False;
{Every time FreeMem is called for allocationg an object, this will register information about the class instanciated:
class name, number of instances, allocated space for one instance
Note: this has to be done on FreeMem because when GetMem is called, the VMT is not installed yet and we can not know
this is an object}
KeepMaxMemoryUsage = CollectStatsAboutObjectAllocation;
{Will report the biggest memory usage during the execution}
ComputeMemoryUsageStats = False;
{Outputs the memory usage along the life of the execution. This output can be easily graphed, in excel for example}
MemoryUsageStatsStep = 5;
{Meaningful only when ComputeMemoryUsageStats
When this is set to 5, we collect information for the stats every 5 call to GetMem, unless size is bigger than StatCollectionForce}
StatCollectionForce = 1000;
BlocksToShow: array[TKindOfMemory] of Boolean = (true, true, true);
{eg if BlocksToShow[MClass] is True, the blocks allocated for class instances will be shown}
CheckHeapStatus = False;
// Checks that the heap has not been corrupted since last call to the memory manager
// Warning: VERY time-consuming
IdentifyObjectFields = False;
IdentifyFieldsOfObjectsConformantTo: TClass = Tobject;
MaxLeak = 1000;
{This option tells to MemCheck not to display more than a certain quantity of leaks, so that the finalization
phase does not take too long}
UseDebugInfos = True;
//Should use the debug informations which are in the executable ?
RaiseExceptionsOnEnd = true;
//Should we use exceptions to show memory leak information ?
NotepadApp = 'notepad';
//The application launched to show the log file
(**************** END OF MEMCHECK OPTIONS ********************)
var
ShowCallStack: Boolean;
{When we show an allocated block, should we show the call stack that went to the allocation ? Set to false
before each block. The usual way to use this is calling Evaluate/Modify just after an EMemoryLeak was raised}
const
MaxListSize = MaxInt div 16 - 1;
type
PObjectsArray = ^TObjectsArray;
TObjectsArray = array[0..MaxListSize] of TObject;
PStringsArray = ^TStringsArray;
TStringsArray = array[0..99999999] of string;
{Used to simulate string lists}
PIntegersArray = ^TIntegersArray;
TIntegersArray = array[0..99999999] of integer;
{Used to simulate lists of integer}
var
TimeStamps: PStringsArray = nil;
{Allows associating a string of information with a time stamp}
TimeStampsCount: integer = 0;
{Number of time stamps in the array}
TimeStampsAllocated: integer = 0;
{Number of positions available in the array}
const
DeallocateInstancesConformingTo = False;
InstancesConformingToForDeallocation: TClass = TObject;
{used only when BlocksToShow[MClass] is True - eg If InstancesConformingTo = TList, only blocks allocated for instances
of TList and its heirs will be shown}
InstancesConformingToForReporting: TClass = TObject;
{used only when BlocksToShow[MClass] is True - eg If InstancesConformingTo = TList, only blocks allocated for instances
of TList and its heirs will be shown}
MaxNbSupportedVMTEntries = 200;
{Don't change this number, its a Hack! jm}
type
PMemoryBlocHeader = ^TMemoryBlocHeader;
TMemoryBlocHeader = record
{
This is the header we put in front of a memory block
For each memory allocation, we allocate "size requested + header size + footer size" because we keep information inside the memory zone.
Therefore, the address returned by GetMem is: [the address we get from OldMemoryManager.GetMem] + HeaderSize.
. DestructionAdress: an identifier telling if the bloc is active or not (when FreeMem is called we do not really free the mem).
Nil when the block has not been freed yet; otherwise, contains the address of the caller of the destruction. This will be useful
for reporting errors such as "this memory has already been freed, at address XXX".
. PreceedingBlock: link of the linked list of allocated blocs
. NextBlock: link of the linked list of allocated blocs
. KindOfBlock: is the data an object or unknown kind of data (such as a buffer)
. VMT: the classtype of the object
. CallerAddress: an array containing the call stack at allocation time
. AllocatedSize: the size allocated for the user (size requested by the user)
. MagicNumber: an integer we use to recognize a block which was allocated using our own allocator
}
DestructionAdress: Pointer;
PreceedingBlock: Pointer;
NextBlock: Pointer;
KindOfBlock: TKindOfMemory;
VMT: TClass;
CallerAddress: TCallStack;
AllocatedSize: integer; //this is an integer because the parameter of GetMem is an integer
LastTimeStamp: integer; //-1 means no time stamp
NotUsed: Cardinal; //Because Size of the header must be a multiple 8
MagicNumber: Cardinal;
end;
PMemoryBlockFooter = ^TMemoryBlockFooter;
TMemoryBlockFooter = Cardinal;
{This is the end-of-bloc marker we use to check that the user did not write beyond the allowed space}
EMemoryLeak = class(Exception);
EStackUnwinding = class(EMemoryLeak);
EBadInstance = class(Exception);
{This exception is raised when a virtual method is called on an object which has been freed}
EFreedBlockDamaged = class(Exception);
EInterfaceFreedInstance = class(Exception);
{This exception is raised when a method is called on an interface whom object has been freed}
VMTTable = array[0..MaxNbSupportedVMTEntries] of pointer;
pVMTTable = ^VMTTable;
TMyVMT = record
A: array[0..19] of byte;
B: VMTTable;
end;
ReleasedInstance = class
procedure RaiseExcept;
procedure InterfaceError; stdcall;
procedure Error; virtual;
end;
TFieldInfo = class
OwnerClass: TClass;
FieldIndex: integer;
constructor Create(const TheOwnerClass: TClass; const TheFieldIndex: integer);
end;
const
EndOfBlock: Cardinal = $FFFFFFFA;
Magic: Cardinal = $FFFFFFFF;
var
FreedInstance: PChar;
BadObjectVMT: TMyVMT;
BadInterfaceVMT: VMTTable;
GIndex: Integer;
LastBlock: PMemoryBlocHeader;
MemCheckActive: boolean = False;
{Is MemCheck currently running ?
ie, is the current memory manager memcheck's ?}
MemCheckInitialized: Boolean = False;
{Has InitializeOnce been called ?
This variable should ONLY be used by InitializeOnce and the finalization}
{*** arrays for stats ***}
AllocatedObjectsClasses: array of TClass;
NbClasses: integer = 0;
AllocatedInstances: PIntegersArray = nil; {instances counter}
AllocStatsCount: integer = 0;
StatsArraysAllocatedPos: integer = 0;
{This is used to display some statistics about objects allocated. Each time an object is allocated, we look if its
class name appears in this list. If it does, we increment the counter of class' instances for this class;
if it does not appear, we had it with a counter set to one.}
MemoryUsageStats: PIntegersArray = nil; {instances counter}
MemoryUsageStatsCount: integer = 0;
MemoryUsageStatsAllocatedPos: integer = 0;
MemoryUsageStatsLoop: integer = -1;
SevereExceptionsLogFile: Text;
{This is the log file for exceptions}
OutOfMemory: EOutOfMemory;
// Because when we have to raise this, we do not want to have to instanciate it (as there is no memory available)
HeapCorrupted: Exception;
NotDestroyedFields: PIntegersArray = nil;
NotDestroyedFieldsInfos: PObjectsArray = nil;
NotDestroyedFieldsCount: integer = 0;
NotDestroyedFieldsAllocatedSpace: integer = 0;
LastHeapStatus: THeapStatus;
MaxMemoryUsage: Integer = 0;
// see KeepMaxMemoryUsage
OldMemoryManager: TMemoryManager;
//Set by the MemChk routine
type
TIntegerBinaryTree = class
protected
fValue: Cardinal;
fBigger: TIntegerBinaryTree;
fSmaller: TIntegerBinaryTree;
class function StoredValue(const Address: Cardinal): Cardinal;
constructor _Create(const Address: Cardinal);
function _Has(const Address: Cardinal): Boolean;
procedure _Add(const Address: Cardinal);
procedure _Remove(const Address: Cardinal);
public
function Has(const Address: Cardinal): Boolean;
procedure Add(const Address: Cardinal);
procedure Remove(const Address: Cardinal);
property Value: Cardinal read fValue;
end;
PCardinal = ^Cardinal;
var
CurrentlyAllocatedBlocksTree: TIntegerBinaryTree;
type
TAddressToLine = class
public
Address: Cardinal;
Line: Cardinal;
constructor Create(const AAddress, ALine: Cardinal);
end;
PAddressesArray = ^TAddressesArray;
TAddressesArray = array[0..MaxInt div 16 - 1] of TAddressToLine;
TUnitDebugInfos = class
public
Name: string;
Addresses: array of TAddressToLine;
constructor Create(const AName: string; const NbLines: Cardinal);
function LineWhichContainsAddress(const Address: Cardinal): string;
end;
TRoutineDebugInfos = class
public
Name: string;
StartAddress: Cardinal;
EndAddress: Cardinal;
constructor Create(const AName: string; const AStartAddress: Cardinal; const ALength: Cardinal);
end;
var
Routines: array of TRoutineDebugInfos;
RoutinesCount: integer;
Units: array of TUnitDebugInfos;
UnitsCount: integer;
OutputFileHeader: string = 'MemCheck version 2.73'#13#10;
HeapStatusSynchro : TSynchroObject;
{$IFDEF USE_JEDI_JCL}
function PointerToDebugInfo(Addr: Pointer): String; //!! by ray
var
_file, _module, _proc: AnsiString;
_line: Integer;
begin
JclDebug.MapOfAddr(Addr, _file, _module, _proc, _line);
if _file <> '' then
Result := Format('($%p) %s:%s:%d (%s)', [Addr, _module, _proc, _line, _file])
else
Result := Format('($%p) %s', [Addr, NoDebugInfo]);
end;
{$ENDIF}
function BlockAllocationAddress(P: Pointer): Pointer;
var
Block: PMemoryBlocHeader;
begin
Block := PMemoryBlocHeader(PChar(P) - SizeOf(TMemoryBlocHeader));
if Block.MagicNumber = Magic then
Result := Block.CallerAddress[0]
else
Result := nil
end;
procedure UpdateLastHeapStatus;
begin
LastHeapStatus := GetHeapStatus;
end;
function HeapStatusesDifferent(const Old, New: THeapStatus): boolean;
begin
Result :=
(Old.TotalAddrSpace <> New.TotalAddrSpace) or
(Old.TotalUncommitted <> New.TotalUncommitted) or
(Old.TotalCommitted <> New.TotalCommitted) or
(Old.TotalAllocated <> New.TotalAllocated) or
(Old.TotalFree <> New.TotalFree) or
(Old.FreeSmall <> New.FreeSmall) or
(Old.FreeBig <> New.FreeBig) or
(Old.Unused <> New.Unused) or
(Old.Overhead <> New.Overhead) or
(Old.HeapErrorCode <> New.HeapErrorCode) or
(New.TotalUncommitted + New.TotalCommitted <> New.TotalAddrSpace) or
(New.Unused + New.FreeBig + New.FreeSmall <> New.TotalFree)
end;
class function TIntegerBinaryTree.StoredValue(const Address: Cardinal): Cardinal;
begin
Result := Address shl 16;
Result := Result or (Address shr 16);
Result := Result xor $AAAAAAAA;
end;
constructor TIntegerBinaryTree._Create(const Address: Cardinal);
begin //We do not call inherited Create for optimization
fValue := Address
end;
function TIntegerBinaryTree.Has(const Address: Cardinal): Boolean;
begin
Result := _Has(StoredValue(Address));
end;
procedure TIntegerBinaryTree.Add(const Address: Cardinal);
begin
_Add(StoredValue(Address));
end;
procedure TIntegerBinaryTree.Remove(const Address: Cardinal);
begin
_Remove(StoredValue(Address));
end;
function TIntegerBinaryTree._Has(const Address: Cardinal): Boolean;
begin
if fValue = Address then
Result := True
else
if (Address > fValue) and (fBigger <> nil) then
Result := fBigger._Has(Address)
else
if (Address < fValue) and (fSmaller <> nil) then
Result := fSmaller._Has(Address)
else
Result := False
end;
procedure TIntegerBinaryTree._Add(const Address: Cardinal);
begin
Assert(Address <> fValue, 'TIntegerBinaryTree._Add: already in !');
if (Address > fValue) then
begin
if fBigger <> nil then
fBigger._Add(Address)
else
fBigger := TIntegerBinaryTree._Create(Address)
end
else
begin
if fSmaller <> nil then
fSmaller._Add(Address)
else
fSmaller := TIntegerBinaryTree._Create(Address)
end
end;
procedure TIntegerBinaryTree._Remove(const Address: Cardinal);
var
Owner, Node: TIntegerBinaryTree;
NodeIsOwnersBigger: Boolean;
Middle, MiddleOwner: TIntegerBinaryTree;
begin
Owner := nil;
Node := CurrentlyAllocatedBlocksTree;
while (Node <> nil) and (Node.fValue <> Address) do
begin
Owner := Node;
if Address > Node.Value then
Node := Node.fBigger
else
Node := Node.fSmaller
end;
Assert(Node <> nil, 'TIntegerBinaryTree._Remove: not in');
NodeIsOwnersBigger := Node = Owner.fBigger;
if Node.fBigger = nil then
begin
if NodeIsOwnersBigger then
Owner.fBigger := Node.fSmaller
else
Owner.fSmaller := Node.fSmaller;
end
else
if Node.fSmaller = nil then
begin
if NodeIsOwnersBigger then
Owner.fBigger := Node.fBigger
else
Owner.fSmaller := Node.fBigger;
end
else
begin
Middle := Node.fSmaller;
MiddleOwner := Node;
while Middle.fBigger <> nil do
begin
MiddleOwner := Middle;
Middle := Middle.fBigger;
end;
if Middle = Node.fSmaller then
begin
if NodeIsOwnersBigger then
Owner.fBigger := Middle
else
Owner.fSmaller := Middle;
Middle.fBigger := Node.fBigger
end
else
begin
MiddleOwner.fBigger := Middle.fSmaller;
Middle.fSmaller := Node.fSmaller;
Middle.fBigger := Node.fBigger;
if NodeIsOwnersBigger then
Owner.fBigger := Middle
else
Owner.fSmaller := Middle
end;
end;
Node.Destroy;
end;
constructor TFieldInfo.Create(const TheOwnerClass: TClass; const TheFieldIndex: integer);
begin
inherited Create;
OwnerClass := TheOwnerClass;
FieldIndex := TheFieldIndex;
end;
const
TObjectVirtualMethodNames: array[1..8] of string = ('SafeCallException', 'AfterConstruction', 'BeforeDestruction', 'Dispatch', 'DefaultHandler', 'NewInstance', 'FreeInstance', 'Destroy');
AddressOfNewInstance: pointer = @TObject.NewInstance;
AddressOfTObjectCreate: pointer = @TObject.Create;
function CallerOfCaller: pointer; //with stack frames !
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@EndOfStack
mov eax, [EBP]
cmp eax, ebp
jb @@EndOfStack
mov eax, [eax + 4]
sub eax, 4
ret
@@EndOfStack:
mov eax, $FFFF
end;
function Caller: pointer; //with stack frame !
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@EndOfStack
mov eax, [ebp + 4]
sub eax, 4
ret
@@EndOfStack:
mov eax, $FFFF
end;
function CallerOfGetMem: pointer; //System._GetMem has no stack frame
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@EndOfStack
{$IFDEF DELPHI6_OR_LATER}
{$IFNDEF DELPHI71_OR_LATER}
mov eax, [ebp + 12]
{$ELSE}
mov eax, [ebp + 16]
{$ENDIF}
{$ELSE}
mov eax, [ebp + 8]
{$ENDIF}
ret
@@EndOfStack:
mov eax, $FFFF
end;
function CallerOfReallocMem: pointer; //System._ReallocMem has no stack frame
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@EndOfStack
mov eax, [EBP + 12]
sub eax, 4
ret
@@EndOfStack:
mov eax, $FFFF
end;
{$IFNDEF VER140}
function CallerIsNewAnsiString: boolean; //NewAnsiString has no stack frame
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@no
mov eax, [ebp + 8]
sub eax, 13
cmp eax, offset System.@NewAnsiString
je @@yes
@@no:
mov eax, 0
ret
@@yes:
mov eax, 1
end;
{$ENDIF}
function CallerIsNewInstance: boolean; //TObject.NewInstance has no stack frame
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@no
{$IFNDEF DELPHI6_OR_LATER}
mov eax, [ebp + 8]
sub eax, 9
{$ELSE}
{$IFNDEF DELPHI71_OR_LATER}
mov eax, [EBP + 12]
sub eax, 15
{$ELSE}
mov eax, [EBP + 16]
sub eax, 15
{$ENDIF}
{$ENDIF}
cmp eax, AddressOfNewInstance
je @@yes
@@no:
mov eax, 0
ret
@@yes:
mov eax, 1
end;
{$IFDEF DELPHI6_OR_LATER}
function ltfm_CallerOfFreeInstance: pointer;
//Tells the address of the caller of FreeInstance from LeakTrackingFreeMem
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@EndOfStack
mov eax, [EBP + 28]
sub eax, 4
ret
@@EndOfStack:
mov eax, $FFFF
end;
function ltfm_CallerOf_FreeMem: pointer;
//Tells the address of the caller of System._FreeMem from LeakTrackingFreeMem
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@EndOfStack
mov eax, [EBP + 12]
sub eax, 4
ret
@@EndOfStack:
mov eax, $FFFF
end;
function ltgmCallerOfGetMemIsTObjectCreate: boolean;
//Tells if the guy who called GetMem is TObject.Create
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@EndOfStack
{$IFNDEF DELPHI71_OR_LATER}
mov eax, [ebp + 36]
{$ELSE}
mov eax, [ebp + 40]
{$ENDIF}
sub eax, 12
cmp eax, AddressOfTObjectCreate
jne @@no
mov eax, 1
ret
@@no:
@@EndOfStack:
mov eax, 0
end;
function ltgmCallerOfTObjectCreate: pointer;
//Tells who called TObject.Create
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@EndOfStack
{$IFNDEF DELPHI71_OR_LATER}
mov eax, [EBP + 56]
{$ELSE}
mov eax, [EBP + 60]
{$ENDIF}
ret
@@EndOfStack:
mov eax, $FFFF
end;
function ltgmCallerIsNewAnsiString: boolean;
//Tells if the guy who called GetMem is NewAnsiString
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@no
{$IFNDEF DELPHI71_OR_LATER}
mov eax, [EBP + 12]
{$ELSE}
mov eax, [EBP + 16]
{$ENDIF}
sub eax, 17
cmp eax, offset System.@NewAnsiString
je @@yes
@@no:
mov eax, 0
ret
@@yes:
mov eax, 1
end;
function CallerIsDynamicArrayAllocation: boolean;
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@no
mov eax, [EBP + 12]
{$IFNDEF DELPHI71_OR_LATER}
add eax, 204
{$ELSE}
add eax, 216
{$ENDIF}
cmp eax, offset System.@DynArraySetLength
je @@yes
@@no:
mov eax, 0
ret
@@yes:
mov eax, 1
end;
{$ENDIF}
procedure ReleasedInstance.RaiseExcept;
var
t: TMemoryBlocHeader;
i: integer;
FeedBackStr: string;
begin
t := PMemoryBlocHeader((PChar(Self) - SizeOf(TMemoryBlocHeader)))^;
try
i := MaxNbSupportedVMTEntries - GIndex + 1;
if i in [1..8] then
FeedBackStr:= 'Call ' + TObjectVirtualMethodNames[i]
else
FeedBackStr:= 'Call ' + IntToStr(i) + 'ｰ virtual method';
FeedBackStr:= FeedBackStr + ' on a FREED instance of ' + T.VMT.ClassName + ' (destroyed at ' + TextualDebugInfoForAddress(Cardinal(T.DestructionAdress)) + ' - had been created at ' + TextualDebugInfoForAddress(Cardinal(T.CallerAddress[0])) + ')';
raise EBadInstance.Create(FeedBackStr) at Caller;
except
on EBadInstance do ;
end;
if ShowCallStack then
for i := 1 to StoredCallStackDepth do
if Integer(T.CallerAddress[i]) > 0 then
try
raise EStackUnwinding.Create('Unwinding level ' + chr(ord('0') + i))at T.CallerAddress[i]
except
on EStackUnwinding do ;
end;
ShowCallStack := False;
end;
function InterfaceErrorCaller: Pointer;
{Returns EBP + 16, which is OK only for InterfaceError !
It would be nice to make this routine local to InterfaceError, but I do not know hot to
implement it in this case - VM}
asm
cmp ebp, 0 //this can happen when there are no stack frames
je @@EndOfStack
mov eax,[EBP+16];
sub eax, 5
ret
@@EndOfStack:
mov eax, $FFFF
end;
procedure ReleasedInstance.InterfaceError;
begin
try
OutputFileHeader := OutputFileHeader + #13#10'Exception: Calling an interface method on an freed Pascal instance @ ' + TextualDebugInfoForAddress(Cardinal(InterfaceErrorCaller)) + #13#10;
raise EInterfaceFreedInstance.Create('Calling an interface method on an freed Pascal instance')at InterfaceErrorCaller
except
on EInterfaceFreedInstance do
;
end;
end;
procedure ReleasedInstance.Error;
{Don't change this, its a Hack! jm}
asm
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);Inc(GIndex);
JMP ReleasedInstance.RaiseExcept;
end;
function MemoryBlockDump(Block: PMemoryBlocHeader): string;
const
MaxDump = 80;
var
i,
count: integer;
s: string[MaxDump];
begin
count := Block.AllocatedSize;
if count > MaxDump then
Count := MaxDump;
Byte(s[0]) := count;
move((PChar(Block) + SizeOf(TMemoryBlocHeader))^, s[1], Count);
for i := 1 to Length(s) do
if s[i] = #0 then s[i] := '.' else
if s[i] < ' ' then
s[i] := '?';
Result := ' Dump: [' + s + ']';
end;
procedure FillCallStack(var St: TCallStack; const NbLevelsToExclude: integer);
{Works only with stack frames - Without, St contains correct info, but is not as deep as it should
I just don't know a general rule for walking the stack when they are not there}
var
StackStart: Pointer;
StackMax: Pointer; //the stack can never go beyond - http://msdn.microsoft.com/library/periodic/period96/S2CE.htm
CurrentFrame: Pointer;
Count, SkipCount: integer;
begin
FillChar(St, SizeOf(St), 0);
asm
mov EAX, FS:[4]
mov StackMax, EAX
mov StackStart, EBP
end;
CurrentFrame:= StackStart;
Count:= 0;
SkipCount:= 0;
while (longint(CurrentFrame) >= longint(StackStart)) and (longint(CurrentFrame) < longint(StackMax)) and (Count <= StoredCallStackDepth) do
begin
if SkipCount >= NbLevelsToExclude then
begin
St[Count]:= Pointer(PInteger(longint(CurrentFrame) + 4)^ - 4);
Count:= Count + 1;
end;
CurrentFrame:= Pointer(PInteger(CurrentFrame)^);
SkipCount:= SkipCount + 1;
end;
end;
procedure AddAllocatedObjectsClass(const C: TClass);
begin
if NbClasses >= Length(AllocatedObjectsClasses) then
begin
UnMemChk;
SetLength(AllocatedObjectsClasses, NbClasses * 2);
MemChk;
end;
AllocatedObjectsClasses[NbClasses] := C;
NbClasses := NbClasses + 1;
end;
procedure CollectNewInstanceOfClassForStats(const TheClass: TClass);
var
i: integer;
begin
i := 0;
while (i < AllocStatsCount) and (AllocatedObjectsClasses[i] <> TheClass) do
i := i + 1;
if i = AllocStatsCount then
begin
if AllocStatsCount = StatsArraysAllocatedPos then
begin
if StatsArraysAllocatedPos = 0 then
StatsArraysAllocatedPos := 10;
StatsArraysAllocatedPos := StatsArraysAllocatedPos * 2;
UnMemChk;
ReallocMem(AllocatedInstances, StatsArraysAllocatedPos * sizeof(Integer));
MemChk;
end;
AddAllocatedObjectsClass(TheClass);
AllocatedInstances[AllocStatsCount] := 1;
AllocStatsCount := AllocStatsCount + 1;
end
else
AllocatedInstances[i] := AllocatedInstances[i] + 1;
end;
var
LinkedListSynchro: TSynchroObject;
procedure AddBlockAtEndOfLinkedList(const B: PMemoryBlocHeader);
begin
LinkedListSynchro.Acquire;
PMemoryBlocHeader(B).PreceedingBlock:= LastBlock;
PMemoryBlocHeader(B).NextBlock:= nil;
if LastBlock <> nil then
LastBlock.NextBlock:= B;
LastBlock:= B;
LinkedListSynchro.Release;
end;
procedure RemoveBlockFromLinkedList(const B: PMemoryBlocHeader);
begin
LinkedListSynchro.Acquire;
if B.NextBlock <> nil then
PMemoryBlocHeader(B.NextBlock).PreceedingBlock:= B.PreceedingBlock;
if B.PreceedingBlock <> nil then
PMemoryBlocHeader(B.PreceedingBlock).NextBlock:= B.NextBlock;
if LastBlock = B then
LastBlock:= B.PreceedingBlock;
LinkedListSynchro.Release;
end;
function LeakTrackingGetMem(Size: Integer): Pointer;
begin
{$IFDEF DELPHI6_OR_LATER}
if ltgmCallerIsNewAnsiString or CallerIsDynamicArrayAllocation then
{$ELSE}
if CallerIsNewAnsiString then
{$ENDIF}
//We do not log memory allocations for reference counted strings. This would take time and some leaks would be reported uselessly. However, if you want to know about this, you can just uncomment this part
//Same for dynamic arrays in Delphi 6 & 7
begin
Result := OldMemoryManager.GetMem(Size);
if Result = nil then
raise OutOfMemory;
end
else
begin
if CallerIsNewInstance then
begin
Result := OldMemoryManager.GetMem(Size + (SizeOf(TMemoryBlocHeader)));
if Result = nil then
raise OutOfMemory;
PMemoryBlocHeader(Result).KindOfBlock := MClass;
if StoredCallStackDepth > 0 then
{$IFDEF DELPHI6_OR_LATER}
if ltgmCallerOfGetMemIsTObjectCreate then
begin
FillCallStack(PMemoryBlocHeader(Result).CallerAddress, 1);
PMemoryBlocHeader(Result).CallerAddress[0]:= ltgmCallerOfTObjectCreate;
end
else
{$ENDIF}
FillCallStack(PMemoryBlocHeader(Result).CallerAddress, 2);
end
else
begin //Neither an object nor a string, this is a MUser
Result := OldMemoryManager.GetMem(Size + (SizeOf(TMemoryBlocHeader) + SizeOf(TMemoryBlockFooter)));
if Result = nil then
raise OutOfMemory;
PMemoryBlocHeader(Result).KindOfBlock := MUser;
if StoredCallStackDepth > 0 then
FillCallStack(PMemoryBlocHeader(Result).CallerAddress, 1);
PMemoryBlocHeader(Result).CallerAddress[0]:= CallerOfGetMem;
PMemoryBlockFooter(PChar(Result) + SizeOf(TMemoryBlocHeader) + Size)^ := EndOfBlock;
end;
AddBlockAtEndOfLinkedList(Result);
PMemoryBlocHeader(Result).LastTimeStamp := TimeStampsCount - 1;
PMemoryBlocHeader(Result).DestructionAdress := nil;
PMemoryBlocHeader(Result).AllocatedSize := Size;
PMemoryBlocHeader(Result).MagicNumber := Magic;
if IdentifyObjectFields then
begin
UnMemChk;
CurrentlyAllocatedBlocksTree.Add(integer(Result));
MemChk;
end;
Inc(integer(Result), SizeOf(TMemoryBlocHeader));
if ComputeMemoryUsageStats then
begin
MemoryUsageStatsLoop := MemoryUsageStatsLoop + 1;
if MemoryUsageStatsLoop = MemoryUsageStatsStep then
MemoryUsageStatsLoop := 0;
if (MemoryUsageStatsLoop = 0) or (Size > StatCollectionForce) then
begin
if MemoryUsageStatsCount = MemoryUsageStatsAllocatedPos then
begin
if MemoryUsageStatsAllocatedPos = 0 then
MemoryUsageStatsAllocatedPos := 10;
MemoryUsageStatsAllocatedPos := MemoryUsageStatsAllocatedPos * 2;
UnMemChk;
ReallocMem(MemoryUsageStats, MemoryUsageStatsAllocatedPos * sizeof(Integer));
MemChk;
end;
MemoryUsageStats[MemoryUsageStatsCount] := AllocMemSize;
MemoryUsageStatsCount := MemoryUsageStatsCount + 1;
end;
end;
if KeepMaxMemoryUsage and (AllocMemSize > MaxMemoryUsage) then
MaxMemoryUsage := AllocMemSize;
end;
end;
function HeapCheckingGetMem(Size: Integer): Pointer;
begin
HeapStatusSynchro.Acquire;
Result:= nil; //Note: I don't understand right now why I get a warning if I suppress this line
try
if HeapStatusesDifferent(LastHeapStatus, GetHeapStatus) then
raise HeapCorrupted;
Result := OldMemoryManager.GetMem(Size);
UpdateLastHeapStatus;
finally
HeapStatusSynchro.Release;
end;
end;
function MemoryBlockFreed(Block: PMemoryBlocHeader): Boolean;
begin
Result := Block.DestructionAdress <> nil;
end;
function MemoryBlockOverwritten(Block: PMemoryBlocHeader): Boolean;
begin
if (block.KindOfBlock = MClass) then
Result:= false //We don't put a footer for objects - This could be done if interesting
else
Result:= PMemoryBlockFooter(PChar(Block) + SizeOf(TMemoryBlocHeader) + Block.AllocatedSize)^ <> EndOfBlock;
end;
function MemCheckBlockCorrupted(Block: PMemoryBlocHeader): Boolean;
begin
Result := MemoryBlockFreed(Block) or MemoryBlockOverwritten(Block);
end;
function MemoryBlockCorrupted(P: Pointer): Boolean;
var
Block: PMemoryBlocHeader;
begin
if PCardinal(PChar(P) - 4)^ = Magic then
begin
Block := PMemoryBlocHeader(PChar(P) - SizeOf(TMemoryBlocHeader));
Result:= MemCheckBlockCorrupted(Block);
end
else
Result := False
end;
procedure ReplaceInterfacesWithBadInterface(AClass: TClass; Instance: Pointer);
{copied and modified from System.Pas: replaces all INTERFACES in Pascal Objects
with a reference to our dummy INTERFACE VMT}
asm
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV EAX,EDX
MOV EDX,ESP
@@0: MOV ECX,[EBX].vmtIntfTable
TEST ECX,ECX
JE @@1
PUSH ECX
@@1: MOV EBX,[EBX].vmtParent
TEST EBX,EBX
JE @@2
MOV EBX,[EBX]
JMP @@0
@@2: CMP ESP,EDX
JE @@5
@@3: POP EBX
MOV ECX,[EBX].TInterfaceTable.EntryCount
ADD EBX,4
@@4: LEA ESI, BadInterfaceVMT // mettre dans ESI l'adresse du d饕ut de MyInterfaceVMT: correct ?????
MOV EDI,[EBX].TInterfaceEntry.IOffset
MOV [EAX+EDI],ESI
ADD EBX,TYPE TInterfaceEntry
DEC ECX
JNE @@4
CMP ESP,EDX
JNE @@3
@@5: POP EDI
POP ESI
POP EBX
end;
function FindMem(Base, ToFind: pointer; Nb: integer): integer;
// Base = instance, Nb = nombre de bloc (HORS VMT!)
asm
// eax=base; edx=Tofind; ecx=Nb
@loop:
cmp [eax+ecx*4], edx
je @found
dec ecx
jne @loop
@found:
mov eax,ecx
end;
procedure AddFieldInfo(const FieldAddress: Pointer; const OwnerClass: TClass; const FieldPos: integer);
begin
UnMemChk;
if NotDestroyedFieldsCount = NotDestroyedFieldsAllocatedSpace then
begin
if NotDestroyedFieldsAllocatedSpace = 0 then
NotDestroyedFieldsAllocatedSpace := 10;
NotDestroyedFieldsAllocatedSpace := NotDestroyedFieldsAllocatedSpace * 2;
ReallocMem(NotDestroyedFields, NotDestroyedFieldsAllocatedSpace * sizeof(integer));
ReallocMem(NotDestroyedFieldsInfos, NotDestroyedFieldsAllocatedSpace * sizeof(integer));
end;
NotDestroyedFields[NotDestroyedFieldsCount] := integer(FieldAddress);
NotDestroyedFieldsInfos[NotDestroyedFieldsCount] := TFieldInfo.Create(OwnerClass, FieldPos);
NotDestroyedFieldsCount := NotDestroyedFieldsCount + 1;
MemChk;
end;
function LeakTrackingFreeMem(P: Pointer): Integer;
var
Block: PMemoryBlocHeader;
i: integer;
begin
if PCardinal(PChar(P) - 4)^ = Magic then
{we recognize a block we marked}
begin
Block := PMemoryBlocHeader(PChar(P) - SizeOf(TMemoryBlocHeader));
if CollectStatsAboutObjectAllocation and (Block.KindOfBlock = MClass) then
CollectNewInstanceOfClassForStats(TObject(P).ClassType);
if IdentifyObjectFields then
begin
if (Block.KindOfBlock = MClass) and (TObject(P).InheritsFrom(IdentifyFieldsOfObjectsConformantTo)) then
for i := 1 to (Block.AllocatedSize div 4) - 1 do
if (PInteger(PChar(P) + i * 4)^ > SizeOf(TMemoryBlocHeader)) and CurrentlyAllocatedBlocksTree.Has(PInteger(PChar(P) + i * 4)^ - SizeOf(TMemoryBlocHeader)) then
AddFieldInfo(Pointer(PInteger(PChar(P) + i * 4)^ - SizeOf(TMemoryBlocHeader)), TObject(P).ClassType, i);
UnMemChk;
if not MemoryBlockFreed(Block) then
begin
Assert(CurrentlyAllocatedBlocksTree.Has(integer(Block)), 'freemem: block not among allocated ones');
CurrentlyAllocatedBlocksTree.Remove(integer(Block));
end;
MemChk;
end;
if MemoryBlockFreed(Block) then
begin
try
OutputFileHeader := OutputFileHeader + #13#10'Exception: second release of block attempt, allocated at ' + TextualDebugInfoForAddress(Cardinal(Block.CallerAddress[0])) + ' - Already freed at ' + TextualDebugInfoForAddress(Cardinal(Block.DestructionAdress)) + #13#10;
raise EMemoryLeak.Create('second release of block attempt, already freed') at Block.DestructionAdress;
except
on EMemoryLeak do ;
end;
if ShowCallStack then
for i := 1 to StoredCallStackDepth do
if Integer(Block.CallerAddress[i]) > 0 then
try
raise EStackUnwinding.Create('Unwinding level ' + chr(ord('0') + i))at Block.CallerAddress[i]
except
on EStackUnwinding do ;
end;
ShowCallStack := False;
end
else
begin
if MemoryBlockOverwritten(Block) then
begin
try
OutputFileHeader := OutputFileHeader + #13#10'Exception: memory damaged beyond block allocated space, allocated at ' + TextualDebugInfoForAddress(Cardinal(BlockAllocationAddress(P))) + #13#10;
raise EMemoryLeak.Create('memory damaged beyond block allocated space, allocated at ' + TextualDebugInfoForAddress(Cardinal(BlockAllocationAddress(P)))) at CallerOfCaller;
except
on EMemoryLeak do ;
end;
end;
if (Block.AllocatedSize > DeallocateFreedMemoryWhenBlockBiggerThan) or (DeallocateInstancesConformingTo and (Block.KindOfBlock = MClass) and (TObject(P) is InstancesConformingToForDeallocation)) then
{we really deallocate the block}
begin
RemoveBlockFromLinkedList(Block);
OldMemoryManager.FreeMem(Block);
end
else
begin //Normal case, not an error
{$IFDEF DELPHI6_OR_LATER}
if Block.KindOfBlock = MClass then
Block.DestructionAdress:= ltfm_CallerOfFreeInstance
else
Block.DestructionAdress:= ltfm_CallerOf_FreeMem;
{$ELSE}
Block.DestructionAdress:= CallerOfCaller;
{$ENDIF}
if WipeOutMemoryOnFreeMem then
if Block.KindOfBlock = MClass then
begin
Block.VMT := TObject(P).ClassType;
FillChar((PChar(P) + 4)^, Block.AllocatedSize - 4, CharToUseToWipeOut);
PInteger(P)^ := Integer(FreedInstance);
if DanglingInterfacesVerified then
ReplaceInterfacesWithBadInterface(Block.VMT, TObject(P))
end
else
FillChar(P^, Block.AllocatedSize, CharToUseToWipeOut);
end;
end;
Result := 0;
end
else
Result := OldMemoryManager.FreeMem(P);
end;
function HeapCheckingFreeMem(P: Pointer): Integer;
begin
if HeapStatusesDifferent(LastHeapStatus, GetHeapStatus) then
raise HeapCorrupted;
Result := OldMemoryManager.FreeMem(P);
UpdateLastHeapStatus;
end;
function LeakTrackingReallocMem(P: Pointer; Size: Integer): Pointer;
var
Block: PMemoryBlocHeader;
begin
if PCardinal(PChar(P) - 4)^ = Magic then
begin
GetMem(Result, Size);
Block:= PMemoryBlocHeader(PChar(Result) - SizeOf(TMemoryBlocHeader));
if StoredCallStackDepth > 0 then
FillCallStack(Block.CallerAddress, 1);
Block.CallerAddress[0]:= CallerOfReallocMem;
Block.KindOfBlock := MReallocedUser;
if Size > PMemoryBlocHeader(PChar(P) - SizeOf(TMemoryBlocHeader)).AllocatedSize then
Move(P^, Result^, PMemoryBlocHeader(PChar(P) - SizeOf(TMemoryBlocHeader)).AllocatedSize)
else
Move(P^, Result^, Size);
LeakTrackingFreeMem(P);
end
else
Result := OldMemoryManager.ReallocMem(P, Size);
end;
function HeapCheckingReallocMem(P: Pointer; Size: Integer): Pointer;
begin
if HeapStatusesDifferent(LastHeapStatus, GetHeapStatus) then
raise HeapCorrupted;
Result := OldMemoryManager.ReallocMem(P, Size);
UpdateLastHeapStatus;
end;
procedure UnMemChk;
begin
SetMemoryManager(OldMemoryManager);
MemCheckActive := False;
end;
function IsMemFilledWithChar(P: Pointer; N: Integer; C: Char): boolean;
//is the memory at P made of C on N bytes ?
asm
//EAX: P - EDX: N - CL: C
@loop:
cmp [eax+edx-1],cl
jne @diff
dec edx
jne @loop
mov eax,1
ret
@diff:
xor eax,eax
end;
procedure GoThroughAllocatedBlocks;
{traverses the allocated blocks list and for each one, raises exceptions showing the memory leaks}
var
Block: PMemoryBlocHeader;
i: integer;
S: ShortString;
begin
if RaiseExceptionsOnEnd then
begin
UnMemChk;
Block := LastBlock; //note: no thread safety issue here
ShowCallStack := False; {for first block}
while Block <> nil do
begin
if BlocksToShow[Block.KindOfBlock] then
begin
if not MemoryBlockFreed(Block) then
{this is a leak}
begin
case Block.KindOfBlock of
MClass:
S := TObject(PChar(Block) + SizeOf(TMemoryBlocHeader)).ClassName;
MUser:
S := 'User';
MReallocedUser:
S := 'Realloc';
end;
if (BlocksToShow[Block.KindOfBlock]) and ((Block.KindOfBlock <> MClass) or (TObject(PChar(Block) + SizeOf(TMemoryBlocHeader)) is InstancesConformingToForReporting)) then
try
raise EMemoryLeak.Create(S + ' allocated at ' + TextualDebugInfoForAddress(Cardinal(Block.CallerAddress[0])))at Block.CallerAddress[0];
except
on EMemoryLeak do ;
end;
if ShowCallStack then
for i := 1 to StoredCallStackDepth do
if Integer(Block.CallerAddress[i]) > 0 then
try
raise EStackUnwinding.Create(S + ' unwinding level ' + chr(ord('0') + i))at Block.CallerAddress[i]
except
on EStackUnwinding do ;
end;
ShowCallStack := False;
end {Block.DestructionAdress = Nil}
else
{this is not a leak}
if CheckWipedBlocksOnTermination and (Block.AllocatedSize > 5) and (Block.AllocatedSize <= DoNotCheckWipedBlocksBiggerThan) and (not IsMemFilledWithChar(pchar(Block) + SizeOf(TMemoryBlocHeader) + 4, Block.AllocatedSize - 5, CharToUseToWipeOut)) then
begin
try
raise EFreedBlockDamaged.Create('Destroyed block damaged - Block allocated at ' + TextualDebugInfoForAddress(Cardinal(Block.CallerAddress[0])) + ' - destroyed at ' + TextualDebugInfoForAddress(Cardinal(Block.DestructionAdress)))at Block.CallerAddress[0]
except
on EFreedBlockDamaged do ;
end;
end;
end;
Block := Block.PreceedingBlock;
end;
end;
end;
procedure dummy; forward;
procedure ChangeFinalizationsOrder;
//Changes the order in which finalizations will occur. The five last units to be finalized must be MemCheck, Classes, Variants, SysUtils and System (in this order)
//Warning: this routine is likely to need to be rewritten when upgrading Delphi
type
PPackageUnitEntry = ^PackageUnitEntry;
var
UnitsInfo: PackageInfo;
//This variable will contain the same thing as System.InitContext.InitTable^.UnitInfo, which is unfortunately not public, and changes between versions of Delphi
NewUnitsInfoOrder: TList; //of PPackageUnitEntry
i: integer;
CurrentUnitInfo: PackageUnitEntry;
CurrentUnitInfoCopy: PPackageUnitEntry;
ProcessHandle: THandle;
BytesWritten: cardinal;
const
DummyToFinalizationOffset = {$IFOPT I+}356{$ELSE}352{$ENDIF};
begin
{$IFNDEF DELPHI7_OR_LATER}
UnitsInfo:= PackageInfo(pointer(Pointer(PChar(@AllocMemSize) + 31 * 4 + 8)^)); //Hacky, no ? I learnt to count on my fingers ! (this stuff is not exported by system.pas)
{$ELSE}
UnitsInfo := PInitContext(PChar(@AllocMemSize) + 128).InitTable;
{$ENDIF}
NewUnitsInfoOrder:= TList.Create;
for i:= 0 to UnitsInfo.UnitCount - 1 do
begin
CurrentUnitInfo:= UnitsInfo.UnitInfo^[i];
GetMem(CurrentUnitInfoCopy, SizeOf(PackageUnitEntry));
CurrentUnitInfoCopy^:= CurrentUnitInfo;
if {$IFNDEF DELPHI6_OR_LATER}@{$ENDIF}CurrentUnitInfo.Init = @System.System then
NewUnitsInfoOrder.Insert(0, CurrentUnitInfoCopy)
else
if {$IFNDEF DELPHI6_OR_LATER}@{$ENDIF}CurrentUnitInfo.Init = @SysUtils.SysUtils then
NewUnitsInfoOrder.Insert(1, CurrentUnitInfoCopy)
else
{$IFDEF DELPHI6_OR_LATER}
if CurrentUnitInfo.Init = @Variants.Variants then
NewUnitsInfoOrder.Insert(2, CurrentUnitInfoCopy)
else
{$ENDIF}
if {$IFNDEF DELPHI6_OR_LATER}@{$ENDIF}CurrentUnitInfo.Init = Pointer(PChar(@Dummy) + DummyToFinalizationOffset) then
NewUnitsInfoOrder.Insert(4, CurrentUnitInfoCopy)
else
NewUnitsInfoOrder.Add(CurrentUnitInfoCopy);
end;
ProcessHandle:= openprocess(PROCESS_ALL_ACCESS, True, GetCurrentProcessId);
for i:= 0 to NewUnitsInfoOrder.Count - 1 do
begin
WriteProcessMemory(ProcessHandle, Pointer(PChar(@UnitsInfo^.UnitInfo^[0]) + i * SizeOf(PackageUnitEntry)), NewUnitsInfoOrder[i], SizeOf(PackageUnitEntry), BytesWritten);
FreeMem(NewUnitsInfoOrder[i]);
end;
CloseHandle(ProcessHandle);
NewUnitsInfoOrder.Destroy;
end;
function UnitWhichContainsAddress(const Address: Cardinal): TUnitDebugInfos;
var
Start, Finish, Pivot: integer;
begin
Start := 0;
Finish := UnitsCount - 1;
Result := nil;
while Start <= Finish do
begin
Pivot := Start + (Finish - Start) div 2;
if TUnitDebugInfos(Units[Pivot]).Addresses[0].Address > Address then
Finish := Pivot - 1
else
if TUnitDebugInfos(Units[Pivot]).Addresses[Length(TUnitDebugInfos(Units[Pivot]).Addresses) - 1].Address < Address then
Start := Pivot + 1
else
begin
Result := Units[Pivot];
Start := Finish + 1;
end;
end;
end;
function RoutineWhichContainsAddress(const Address: Cardinal): string;
var
Start, Finish, Pivot: integer;
begin
Start := 0;
Result := NoDebugInfo;
Finish := RoutinesCount - 1;
while Start <= Finish do
begin
Pivot := Start + (Finish - Start) div 2;
if TRoutineDebugInfos(Routines[Pivot]).StartAddress > Address then
Finish := Pivot - 1
else
if TRoutineDebugInfos(Routines[Pivot]).EndAddress < Address then
Start := Pivot + 1
else
begin
Result := ' Routine ' + TRoutineDebugInfos(Routines[Pivot]).Name;
Start := Finish + 1;
end;
end;
end;
type
TExceptionProc = procedure(Exc: TObject; Addr: Pointer);
var
InitialExceptionProc: TExceptionProc;
VersionInfo: string;
procedure MyExceptProc(Exc: TObject; Addr: Pointer);
var
S: TCallStack;
begin
Writeln(SevereExceptionsLogFile, '');
Writeln(SevereExceptionsLogFile, '********* Severe exception detected - ' + DateTimeToStr(Now) + ' *********');
Writeln(SevereExceptionsLogFile, VersionInfo);
Writeln(SevereExceptionsLogFile, 'Exception code: ' + Exc.ClassName);
Writeln(SevereExceptionsLogFile, 'Exception address: ' + TextualDebugInfoForAddress(Cardinal(Addr)));
Writeln(SevereExceptionsLogFile, #13#10'Call stack (oldest call at bottom):');
FillCallStack(S, 0);
Writeln(SevereExceptionsLogFile, CallStackTextualRepresentation(S, ''));
Writeln(SevereExceptionsLogFile, '*****************************************************************');
Writeln(SevereExceptionsLogFile, '');
InitialExceptionProc(Exc, Addr);
//The closing of the file is done in the finalization
end;
procedure LogSevereExceptions(const WithVersionInfo: string);
const
FileNameBufSize = 1000;
var
LogFileName: string;
begin
if ExceptProc <> @MyExceptProc then
{not installed yet ?}
begin
try
SetLength(LogFileName, FileNameBufSize);
GetModuleFileName(0, PChar(LogFileName), FileNameBufSize);
LogFileName := copy(LogFileName, 1, pos('.', LogFileName)) + 'log';
AssignFile(SevereExceptionsLogFile, LogFileName);
if FileExists(LogFileName) then
Append(SevereExceptionsLogFile)
else
Rewrite(SevereExceptionsLogFile);
except
end;
InitialExceptionProc := ExceptProc;
ExceptProc := @MyExceptProc;
VersionInfo := WithVersionInfo;
end;
end;
function IsMemCheckActive: boolean;
begin
Result := MemCheckActive
end;
constructor TUnitDebugInfos.Create(const AName: string; const NbLines: Cardinal);
begin
Name := AName;
SetLength(Addresses, NbLines);
end;
constructor TRoutineDebugInfos.Create(const AName: string; const AStartAddress: Cardinal; const ALength: Cardinal);
begin
Name := AName;
StartAddress := AStartAddress;
EndAddress := StartAddress + ALength - 1;
end;
constructor TAddressToLine.Create(const AAddress, ALine: Cardinal);
begin
Address := AAddress;
Line := ALine
end;
function TUnitDebugInfos.LineWhichContainsAddress(const Address: Cardinal): string;
var
Start, Finish, Pivot: Cardinal;
begin
if Addresses[0].Address > Address then
Result := ''
else
begin
Start := 0;
Finish := Length(Addresses) - 1;
while Start < Finish - 1 do
begin
Pivot := Start + (Finish - Start) div 2;
if Addresses[Pivot].Address = Address then
begin
Start := Pivot;
Finish := Start
end
else
if Addresses[Pivot].Address > Address then
Finish := Pivot
else
Start := Pivot
end;
Result := ' Line ' + IntToStr(Addresses[Start].Line);
end;
end;
type
SRCMODHDR = packed record
_cFile: Word;
_cSeg: Word;
_baseSrcFile: array[0..MaxListSize] of Integer;
end;
SRCFILE = packed record
_cSeg: Word;
_nName: Integer;
_baseSrcLn: array[0..MaxListSize] of Integer;
end;
SRCLN = packed record
_Seg: Word;
_cPair: Word;
_Offset: array[0..MaxListSize] of Integer;
end;
PSRCMODHDR = ^SRCMODHDR;
PSRCFILE = ^SRCFILE;
PSRCLN = ^SRCLN;
TArrayOfByte = array[0..MaxListSize] of Byte;
TArrayOfWord = array[0..MaxListSize] of Word;
PArrayOfByte = ^TArrayOfByte;
PArrayOfWord = ^TArrayOfWord;
PArrayOfPointer = ^TArrayOfPointer;
TArrayOfPointer = array[0..MaxListSize] of PArrayOfByte;
procedure AddRoutine(const Name: string; const Start, Len: Cardinal);
begin
if Length(Routines) <= RoutinesCount then
SetLength(Routines, Max(RoutinesCount * 2, 1000));
Routines[RoutinesCount] := TRoutineDebugInfos.Create(Name, Start, Len);
RoutinesCount := RoutinesCount + 1;
end;
procedure AddUnit(const U: TUnitDebugInfos);
begin
if Length(Units) <= UnitsCount then
SetLength(Units, Max(UnitsCount * 2, 1000));
Units[UnitsCount] := U;
UnitsCount := UnitsCount + 1;
end;
procedure dumpsymbols(NameTbl: PArrayOfPointer; sstptr: PArrayOfByte; size: integer);
//Copyright (C) Tenth Planet Software Intl., Clive Turvey 1998. All rights reserved. - Reused & modified by SG with permission
var
len, sym: integer;
begin
while size > 0 do
begin
len := PWord(@sstptr^[0])^;
sym := PWord(@sstptr^[2])^;
INC(len, 2);
if ((sym = $205) or (sym = $204)) and (PInteger(@sstptr^[40])^ > 0) then
AddRoutine(PChar(NameTbl^[PInteger(@sstptr^[40])^ - 1]), PInteger(@sstptr^[28])^, PInteger(@sstptr^[16])^);
if (len = 2) then
size := 0
else
begin
sstptr := PArrayOfByte(@sstptr^[len]);
DEC(size, len);
end;
end;
end;
procedure dumplines(NameTbl: PArrayOfPointer; sstptr: PArrayOfByte; size: integer);
//Copyright (C) Tenth Planet Software Intl., Clive Turvey 1998. All rights reserved. - Reused & modified by SG with permission
var
srcmodhdr: PSRCMODHDR;
i: Word;
srcfile: PSRCFILE;
srcln: PSRCLN;
k: Word;
CurrentUnit: TUnitDebugInfos;
begin
if size > 0 then
begin
srcmodhdr := PSRCMODHDR(sstptr);
for i := 0 to pred(srcmodhdr^._cFile) do
begin
srcfile := PSRCFILE(@sstptr^[srcmodhdr^._baseSrcFile[i]]);
if srcfile^._nName > 0 then
//note: I assume that the code is always in segment #1. If this is not the case, Houston ! - VM
begin
srcln := PSRCLN(@sstptr^[srcfile^._baseSrcLn[0]]);
CurrentUnit := TUnitDebugInfos.Create(ExtractFileName(PChar(NameTbl^[srcfile^._nName - 1])), srcln^._cPair);
AddUnit(CurrentUnit);
for k := 0 to pred(srcln^._cPair) do
CurrentUnit.Addresses[k] := TAddressToLine.Create(Integer(PArrayOfPointer(@srcln^._Offset[0])^[k]), Integer(PArrayOfWord(@srcln^._Offset[srcln^._cPair])^[k]));
end;
end;
end;
end;
procedure GetProjectInfos;
//Copyright (C) Tenth Planet Software Intl., Clive Turvey 1998. All rights reserved. - Reused & modified by SG with permission
var
AHeader: packed record
Signature: array[0..3] of Char;
AnInteger: Integer;
end;
k: integer;
j: Word;
lfodir: Integer;
SstFrameSize: integer;
SstFrameElem: PArrayOfByte;
ssttype, sstsize, sstbase: Integer;
x, y, z: Integer;
sstbuf: PArrayOfByte;
OldFileMode: integer;
AFileOfByte: file of Byte;
Names: PArrayOfByte;
NameTbl: PArrayOfPointer;
SstFrame: PArrayOfByte;
ifabase: Integer;
cdir, cbdirentry: word;
FileName: string;
begin
RoutinesCount := 0;
UnitsCount := 0;
OldFileMode := FileMode;
FileMode := 0;
SetLength(FileName, MAX_PATH + 1);
SetLength(FileName, GetModuleFileName(HInstance, PChar(FileName), MAX_PATH));
AssignFile(AFileOfByte, FileName);
Reset(AFileOfByte);
Names := nil;
NameTbl := nil;
Seek(AFileOfByte, FileSize(AFileOfByte) - SizeOf(AHeader));
BlockRead(AFileOfByte, AHeader, SizeOf(AHeader));
if (AHeader.Signature = 'FB09') or (AHeader.Signature = 'FB0A') then
begin
ifabase := FilePos(AFileOfByte) - AHeader.AnInteger;
Seek(AFileOfByte, ifabase);
BlockRead(AFileOfByte, AHeader, SizeOf(AHeader));
if (AHeader.Signature = 'FB09') or (AHeader.Signature = 'FB0A') then
begin
lfodir := ifabase + AHeader.AnInteger;
if lfodir >= ifabase then
begin
Seek(AFileOfByte, lfodir);
BlockRead(AFileOfByte, j, SizeOf(Word));
BlockRead(AFileOfByte, cbdirentry, SizeOf(Word));
BlockRead(AFileOfByte, cdir, SizeOf(Word));
Seek(AFileOfByte, lfodir + j);
SstFrameSize := cdir * cbdirentry;
getmem(SstFrame, SstFrameSize);
BlockRead(AFileOfByte, SstFrame^, SstFrameSize);
for k := 0 to pred(cdir) do
begin
SstFrameElem := PArrayOfByte(@SstFrame^[k * cbdirentry]);
ssttype := PWord(@SstFrameElem^[0])^;
if (ssttype = $0130) then
begin
sstbase := ifabase + PInteger(@SstFrameElem^[4])^;
sstsize := PInteger(@SstFrameElem^[8])^;
getmem(Names, sstsize);
Seek(AFileOfByte, sstbase);
BlockRead(AFileOfByte, Names^, sstsize);
y := PInteger(@Names^[0])^;
getmem(NameTbl, sizeof(Pointer) * y);
z := 4;
for x := 0 to pred(y) do
begin
NameTbl^[x] := PArrayOfByte(@Names^[z + 1]);
z := z + Names^[z] + 2;
end;
end;
end;
for k := 0 to pred(cdir) do
begin
SstFrameElem := PArrayOfByte(@SstFrame^[k * cbdirentry]);
ssttype := PWord(@SstFrameElem^[0])^;
sstbase := ifabase + PInteger(@SstFrameElem^[4])^;
sstsize := PInteger(@SstFrameElem^[8])^;
getmem(sstbuf, sstsize);
Seek(AFileOfByte, sstbase);
BlockRead(AFileOfByte, sstbuf^, sstsize);
if (ssttype = $0125) then
dumpsymbols(NameTbl, PArrayOfByte(@sstbuf^[4]), sstsize - 4);
if (ssttype = $0127) then
dumplines(NameTbl, sstbuf, sstsize);
FreeMem(sstbuf);
end;
FreeMem(Names);
FreeMem(NameTbl);
FreeMem(SstFrame);
end;
end;
end;
CloseFile(AFileOfByte);
FileMode := OldFileMode;
end;
procedure BadDestroy;
begin
Writeln('bad destroy');
end;
procedure SetDispl; forward;
procedure InitializeOnce;
var
i: integer;
begin
if not MemCheckInitialized then
{once mechanism}
begin
SetDispl;
OutOfMemory := EOutOfMemory.Create('Memcheck is not able to allocate memory, due to system resource lack');
HeapCorrupted := Exception.Create('Heap corrupted');
ChangeFinalizationsOrder;
MemCheckInitialized := True;
GIndex := 0;
LastBlock := nil;
for I := 0 to MaxNbSupportedVMTEntries do
begin
BadObjectVMT.B[I] := PChar(@ReleasedInstance.Error) + 6 * I;
BadInterfaceVMT[I] := PChar(@ReleasedInstance.InterfaceError);
end;
FreedInstance := Pchar(ReleasedInstance) + vmtMethodTable;
Move(FreedInstance^, BadObjectVMT.A, 20);
FreedInstance := PChar(@BadObjectVMT.B[8]);
if IdentifyObjectFields then
CurrentlyAllocatedBlocksTree := TIntegerBinaryTree.Create;
if CollectStatsAboutObjectAllocation then
SetLength(AllocatedObjectsClasses, 100);
GetProjectInfos;
GetMemoryManager(OldMemoryManager);
LinkedListSynchro:= TCriticalSection.Create;
if CheckHeapStatus then
HeapStatusSynchro:= TSynchroObject.Create;
end;
end;
function CallStacksEqual(const CS1, CS2: TCallStack): Boolean;
var
i: integer;
begin
Result := True;
i := 0;
while (Result) and (i <= StoredCallStackDepth) do
begin
Result := Result and (CS1[i] = CS2[i]);
i := i + 1;
end;
end;
type
TLeak = class
public
fID: integer;
fBlock: PMemoryBlocHeader;
fOccurences: integer;
fWasFieldOfAnotherObject: Boolean;
fOwnerClassName: string;
fOtherFieldIndex: integer;
fOtherIsDestroyed: Boolean;
constructor Create(ABlock: PMemoryBlocHeader);
function IsEqual(const Other: TLeak): Boolean;
procedure AddOccurence;
property Occurences: integer read fOccurences;
property Block: PMemoryBlocHeader read fBlock;
property WasFieldOfAnotherObject: Boolean read fWasFieldOfAnotherObject;
property OtherObjectClassName: string read fOwnerClassName;
property OtherFieldIndex: integer read fOtherFieldIndex;
property OtherIsDestroyed: Boolean read fOtherIsDestroyed;
procedure OutputToFile(const F: Text);
procedure OutputOneLineToFile(const F: Text);
end;
TLeakList = class
public
fItems: array of TLeak;
fCapacity: integer;
fCount: integer;
procedure Add(const L: TLeak);
constructor Create;
function Item(const I: integer): TLeak;
property Count: integer read fCount;
end;
TBlockList = class
public
fItems: array of PMemoryBlocHeader;
fCapacity: integer;
fCount: integer;
procedure Add(const B: PMemoryBlocHeader);
constructor Create;
function Item(const I: integer): PMemoryBlocHeader;
property Count: integer read fCount;
end;
constructor TLeak.Create(ABlock: PMemoryBlocHeader);
begin
inherited Create;
fBlock := ABlock;
fOccurences := 1;
end;
procedure TLeak.OutputToFile(const F: Text);
begin
Write(F, 'Leak #', fID, ' ');
case Block.KindOfBlock of
MClass:
WriteLn(F, 'Instance of ', TObject(PChar(Block) + SizeOf(TMemoryBlocHeader)).ClassName);
MUser:
WriteLn(F, 'User allocated memory (GetMem)');
MReallocedUser:
WriteLn(F, 'Reallocated memory (ReallocMem)');
end;
WriteLn(F, #9'Size: ', Block.AllocatedSize);
if fOccurences > 1 then
WriteLn(F, #9, fOccurences, ' Occurences')
else
WriteLn(F, #9, fOccurences, ' Occurence');
if fWasFieldOfAnotherObject then
begin
Write(F, #9'Was field #', fOtherFieldIndex, ' of an instance of ', fOwnerClassName);
if fOtherIsDestroyed then
WriteLn(F, ' (destroyed)')
else
WriteLn(F, ' (not destroyed)');
end;
WriteLn(F, CallStackTextualRepresentation(Block.CallerAddress, #9));
end;
procedure TLeak.OutputOneLineToFile(const F: Text);
begin
case Block.KindOfBlock of
MClass:
Write(F, '* Instance of ', TObject(PChar(Block) + SizeOf(TMemoryBlocHeader)).ClassName);
MUser:
Write(F, '* User allocated memory (GetMem)');
MReallocedUser:
Write(F, '* Reallocated memory (ReallocMem)');
end;
Write(F, ' (Leak #', fID, ') ');
WriteLn(F, 'Size: ', Block.AllocatedSize);
end;
function TLeak.IsEqual(const Other: TLeak): Boolean;
begin
Result := (fBlock.KindOfBlock = Other.Block.KindOfBlock) and (fBlock.AllocatedSize = Other.Block.AllocatedSize);
if fBlock.KindOfBlock = MClass then
Result := Result and (TObject(PChar(fBlock) + SizeOf(TMemoryBlocHeader)).ClassName = TObject(PChar(Other.Block) + SizeOf(TMemoryBlocHeader)).ClassName);
Result := Result and (WasFieldOfAnotherObject = Other.WasFieldOfAnotherObject);
if WasFieldOfAnotherObject then
Result := Result and (OtherObjectClassName = Other.OtherObjectClassName) and (OtherFieldIndex = Other.OtherFieldIndex) and (OtherIsDestroyed = Other.OtherIsDestroyed);
Result := Result and CallStacksEqual(fBlock.CallerAddress, Other.Block.CallerAddress)
end;
procedure TLeak.AddOccurence;
begin
fOccurences := fOccurences + 1
end;
procedure TLeakList.Add(const L: TLeak);
begin
if Count = fCapacity then
begin
fCapacity := fCapacity * 2;
SetLength(fItems, fCapacity);
end;
fItems[fCount] := L;
fCount := fCount + 1;
end;
constructor TLeakList.Create;
begin
inherited Create;
fCapacity := 10;
fCount := 0;
SetLength(fItems, fCapacity);
end;
function TLeakList.Item(const I: integer): TLeak;
begin
Assert((i >= 0) and (i < fCount), 'TLeakList.Item: out of bounds');
Result := fItems[i]
end;
procedure TBlockList.Add(const B: PMemoryBlocHeader);
begin
if Count = fCapacity then
begin
fCapacity := fCapacity * 2;
SetLength(fItems, fCapacity);
end;
fItems[fCount] := B;
fCount := fCount + 1;
end;
constructor TBlockList.Create;
begin
inherited Create;
fCapacity := 10;
fCount := 0;
SetLength(fItems, fCapacity);
end;
function TBlockList.Item(const I: integer): PMemoryBlocHeader;
begin
Assert((i >= 0) and (i < fCount), 'TBlockList.Item: out of bounds');
Result := fItems[i]
end;
procedure GetLeaks(const LeaksList, ChronogicalInfo: TLeakList; const MaxNumberOfLeaks: integer; var StoppedDueToMaxLeak: Boolean);
var
Block: PMemoryBlocHeader;
CurrentLeak: TLeak;
i: integer;
NewLeak: Boolean;
begin
StoppedDueToMaxLeak := False;
Block := LastBlock;
while (Block <> nil) and (LeaksList.Count < MaxNumberOfLeaks) do
begin
if not MemoryBlockFreed(Block) then
{this is a leak}
begin
CurrentLeak := TLeak.Create(Block);
if IdentifyObjectFields then
for i := 0 to NotDestroyedFieldsCount - 1 do
if pointer(NotDestroyedFields[i]) = Block then
begin
CurrentLeak.fWasFieldOfAnotherObject := True;
CurrentLeak.fOwnerClassName := TFieldInfo(NotDestroyedFieldsInfos[i]).OwnerClass.ClassName;
CurrentLeak.fOtherFieldIndex := TFieldInfo(NotDestroyedFieldsInfos[i]).FieldIndex;
CurrentLeak.fOtherIsDestroyed := True;
end;
//A future improvement: identify fields of not destroyed objects
NewLeak := True;
i := 0;
while i < LeaksList.Count do
begin
if LeaksList.Item(i).IsEqual(CurrentLeak) then
begin
CurrentLeak.Destroy;
CurrentLeak := LeaksList.Item(i);
CurrentLeak.AddOccurence;
i := LeaksList.Count;
NewLeak := False;
end;
i := i + 1;
end;
if NewLeak then
begin
CurrentLeak.fID := LeaksList.Count;
LeaksList.Add(CurrentLeak);
end;
ChronogicalInfo.Add(CurrentLeak);
end;
Block := Block.PreceedingBlock;
end;
if LeaksList.Count = MaxNumberOfLeaks then
StoppedDueToMaxLeak := True;
end;
procedure GetBadBlocks(const B: TBlockList; const MaxNumberOfBlocks, MaxBlockSize: integer; var StoppedDueToMaxBlock: Boolean);
var
Block: PMemoryBlocHeader;
begin
StoppedDueToMaxBlock := False;
Block := LastBlock;
while (Block <> nil) and (B.Count < MaxNumberOfBlocks) do
begin
if MemoryBlockFreed(Block) and (Block.AllocatedSize > 5) and (Block.AllocatedSize <= MaxBlockSize) and (not IsMemFilledWithChar(pchar(Block) + SizeOf(TMemoryBlocHeader) + 4, Block.AllocatedSize - 5, CharToUseToWipeOut)) then
B.Add(Block);
Block := Block.PreceedingBlock;
end;
if B.Count = MaxNumberOfBlocks then
StoppedDueToMaxBlock := True;
end;
procedure OutputAllCollectedInformation;
var
OutputFile: Text;
LeaksList: TLeakList; //Contains all instances of TLeak
ChronogicalInfo: TLeakList; //Contains one ore more instance of each TLeak
StoppedDueToMax: Boolean;
TotalLeak: integer;
i, j: integer;
LastDisplayedTimeStamp: integer;
BadBlocks: TBlockList;
begin
//Initalize
InitializeOnce;
UnMemChk;
LeaksList := TLeakList.Create;
ChronogicalInfo := TLeakList.Create;
//Prepare the output file
if (IOResult <> 0) then ; //Clears the internal IO error flag
AssignFile(OutputFile, MemCheckLogFileName + '.$$$');
Rewrite(OutputFile);
WriteLn(OutputFile, OutputFileHeader);
//We collect the list of allocated blocks
GetLeaks(LeaksList, ChronogicalInfo, MaxLeak, StoppedDueToMax);
//Improve the header
TotalLeak := 0;
for i := 0 to ChronogicalInfo.Count - 1 do
TotalLeak := TotalLeak + ChronogicalInfo.Item(i).Block.AllocatedSize;
if StoppedDueToMax then
WriteLn(OutputFile, 'Total leak not accurate due to MaxLeak constant reached, but at least ', TotalLeak, ' bytes'#13#10)
else
WriteLn(OutputFile, 'Total leak: ', TotalLeak, ' bytes'#13#10);
//We output the memory leaks
WriteLn(OutputFile, #13#10'*** MEMCHK: Blocks STILL allocated ***'#13#10);
for i := 0 to LeaksList.Count - 1 do
LeaksList.Item(i).OutputToFile(OutputFile);
WriteLn(OutputFile, '*** MEMCHK: End of allocated blocks ***'#13#10);
//We give chronological info
WriteLn(OutputFile, #13#10'*** MEMCHK: Chronological leak information ***'#13#10);
if TimeStampsCount > 0 then
WriteLn(OutputFile, ' Time stamp: "', TimeStamps[0], '"');
LastDisplayedTimeStamp := 0;
for i := ChronogicalInfo.Count - 1 downto 0 do
begin
if (TimeStampsCount > 0) and (ChronogicalInfo.Item(i).Block.LastTimeStamp > LastDisplayedTimeStamp) then
begin
for j := LastDisplayedTimeStamp + 1 to ChronogicalInfo.Item(i).Block.LastTimeStamp do
WriteLn(OutputFile, ' Time stamp: "', TimeStamps[j], '"');
LastDisplayedTimeStamp := ChronogicalInfo.Item(i).Block.LastTimeStamp;
end;
ChronogicalInfo.Item(i).OutputOneLineToFile(OutputFile);
end;
for j := LastDisplayedTimeStamp + 1 to TimeStampsCount - 1 do
WriteLn(OutputFile, ' Time stamp: "', TimeStamps[j], '"');
WriteLn(OutputFile, #13#10'*** MEMCHK: End of chronological leak information ***'#13#10);
//Output the allocation stats if necessary
if CollectStatsAboutObjectAllocation then
begin
WriteLn(OutputFile, #13#10'*** MEMCHK: Allocation stats ***'#13#10);
if TotalLeak > 0 then
WriteLn(OutputFile, #9'The information is not accurate since there are memory leaks'#13#10);
WriteLn(OutputFile, #9'Nb instances'#9'Instance size'#9'ClassName');
for i := 0 to AllocStatsCount - 1 do
WriteLn(OutputFile, #9, AllocatedInstances[i], #9#9, AllocatedObjectsClasses[i].InstanceSize, #9#9, AllocatedObjectsClasses[i].ClassName);
WriteLn(OutputFile, #13#10'*** MEMCHK: End of allocation stats ***'#13#10);
end;
if ComputeMemoryUsageStats then
begin
WriteLn(OutputFile, #13#10'*** MEMCHK: Memory usage stats ***'#13#10);
for i := 0 to MemoryUsageStatsCount - 1 do
WriteLn(OutputFile, #9, MemoryUsageStats[i]);
WriteLn(OutputFile, #13#10'*** MEMCHK: End of memory usage stats ***'#13#10);
end;
if KeepMaxMemoryUsage then
WriteLn(OutputFile, #13#10'*** Biggest memory usage was: ', MaxMemoryUsage, ' ***' + #13#10#13#10#13#10);
//Get and output the damaged blocks if necessary
BadBlocks := TBlockList.Create;
if CheckWipedBlocksOnTermination then
begin
GetBadBlocks(BadBlocks, MaxLeak, DoNotCheckWipedBlocksBiggerThan, StoppedDueToMax);
WriteLn(OutputFile, #13#10'*** MEMCHK: Blocks written to after destruction ***'#13#10);
if StoppedDueToMax then
WriteLn(OutputFile, #9'Number of bad blocks not accurate due to MaxLeak constant reached, but at least ', BadBlocks.Count, #13#10)
else
WriteLn(OutputFile, #9'Bad blocks count: ', BadBlocks.Count, #13#10);
for i := 0 to BadBlocks.Count - 1 do
begin
WriteLn(OutputFile, #9'* Destroyed block damaged');
WriteLn(OutputFile, #9#9'Call stack at allocation time:');
Write(OutputFile, CallStackTextualRepresentation(BadBlocks.Item(i).CallerAddress, #9#9#9));
WriteLn(OutputFile, #9#9'Destroyed at: ', TextualDebugInfoForAddress(Cardinal(BadBlocks.Item(i).DestructionAdress)));
end;
WriteLn(OutputFile, #13#10'*** MEMCHK: End of blocks written to after destruction ***'#13#10);
end;
BadBlocks.Destroy;
//Save and display the output file
Close(OutputFile);
if FileExists(MemCheckLogFileName) then
DeleteFile(MemCheckLogFileName);
Rename(OutputFile, MemCheckLogFileName);
if ShowLogFileWhenUseful and (LeaksList.Count > 0) or CollectStatsAboutObjectAllocation or ComputeMemoryUsageStats or KeepMaxMemoryUsage then
WinExec(PChar(NotepadApp + ' ' + MemCheckLogFileName), sw_Show);
//Release the memory
for i := 0 to LeaksList.Count - 1 do
LeaksList.Item(i).Destroy;
LeaksList.Destroy;
ChronogicalInfo.Destroy;
end;
procedure AddTimeStampInformation(const I: string);
begin
InitializeOnce;
if TimeStampsCount = TimeStampsAllocated then
begin
if TimeStampsAllocated = 0 then
TimeStampsAllocated := 10;
TimeStampsAllocated := TimeStampsAllocated * 2;
UnMemChk;
ReallocMem(TimeStamps, TimeStampsAllocated * sizeof(WideString));
ZeroMemory(pointer(integer(TimeStamps) + TimeStampsCount * sizeof(WideString)), (TimeStampsAllocated - TimeStampsCount) * SizeOf(WideString));
MemChk;
end;
TimeStamps[TimeStampsCount] := I + ' (Time stamp: ' + IntToStr(TimeStampsCount) + ')';
TimeStampsCount := TimeStampsCount + 1;
end;
procedure MemChk;
const
LeakTrackingMemoryManager: TMemoryManager = (
GetMem: LeakTrackingGetMem;
FreeMem: LeakTrackingFreeMem;
ReallocMem: LeakTrackingReallocMem;
);
HeapCheckingMemoryManager: TMemoryManager = (
GetMem: HeapCheckingGetMem;
FreeMem: HeapCheckingFreeMem;
ReallocMem: HeapCheckingReallocMem;
);
begin
assert(sizeof(TMemoryBlocHeader) mod 8 = 0, 'SizeOf(TMemoryBlocHeader) in MemCheck should be a multiple of 8');
if not MemCheckActive then
begin
InitializeOnce;
if CheckHeapStatus then
begin
SetMemoryManager(HeapCheckingMemoryManager);
UpdateLastHeapStatus;
end
else
SetMemoryManager(LeakTrackingMemoryManager);
MemCheckActive := True;
end;
end;
procedure CommitReleases;
var
Block, BlockToFree, previous: PMemoryBlocHeader;
begin
InitializeOnce;
Block := LastBlock;
Previous := nil;
while Block <> nil do
begin
BlockToFree := Block;
Block := Block.PreceedingBlock;
if MemoryBlockFreed(BlockToFree) then
begin
if LastBlock = BlockToFree then
LastBlock := Block;
if previous <> nil then
previous.PreceedingBlock := Block;
OldMemoryManager.FreeMem(BlockToFree);
end
else
previous := BlockToFree;
end;
end;
function CallStackTextualRepresentation(const S: TCallStack; const LineHeader: string): string;
var
i: integer;
begin
i := 0;
Result := '';
while (i <= StoredCallStackDepth) and (S[i] <> nil) do
begin
Result := Result + LineHeader + 'call stack - ' + IntToStr(i) + ' : ' + TextualDebugInfoForAddress(Cardinal(S[i])) + #13#10;
i := i + 1;
end;
end;
var
Displ: Cardinal;
{Displ is the displacement of the code in the executable file. The code in SetDispl was written by Juan Vidal Pich}
procedure SetDispl;
var
NTHeader: PImageFileHeader;
NTOptHeader: PImageOptionalHeader;
begin
//-> If you have a compilation error in this routine and you are compiling with delphi 4, I'd say that you did not install the Delphi update pack 3
NTHeader := PImageFileHeader(Cardinal(PImageDosHeader(HInstance)._lfanew) + HInstance + 4); {SizeOf(IMAGE_NT_SIGNATURE) = 4}
NTOptHeader := PImageOptionalHeader(Cardinal(NTHeader) + IMAGE_SIZEOF_FILE_HEADER);
Displ := HInstance + NTOptHeader.BaseOfCode;
//Result := HInstance + PImageNtHeaders(LongInt(HInstance)+PImageDosHeader(HInstance)^._lfanew)^.OptionalHeader.BaseOfCode;
end;
function CardinalToHexa(i: Cardinal): string;
const
HexChars: array[0..15] of char = ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
var
J: integer;
begin
Result := '';
for j := 1 to 8 do
begin
Result := HexChars[i and $0F] + Result;
I := I shr 4;
end;
end;
function TextualDebugInfoForAddress(const TheAddress: Cardinal): string;
{$IFNDEF USE_JEDI_JCL}
var
U: TUnitDebugInfos;
AddressInDebugInfos: Cardinal;
{$ENDIF}
begin
{$IFNDEF USE_JEDI_JCL}
InitializeOnce;
if UseDebugInfos and (TheAddress > Displ) then
begin
AddressInDebugInfos := TheAddress - Displ;
U := UnitWhichContainsAddress(AddressInDebugInfos);
if U <> nil then
Result := 'Module ' + U.Name + RoutineWhichContainsAddress(AddressInDebugInfos) + U.LineWhichContainsAddress(AddressInDebugInfos)
else
Result := RoutineWhichContainsAddress(AddressInDebugInfos);
end
else
Result := NoDebugInfo;
Result := Result + ' Find error: ' + CardinalToHexa(TheAddress);
{$ELSE}
Result := PointerToDebugInfo(Pointer(TheAddress));
{$ENDIF}
end;
procedure dummy;
{This procedure is never called. It is used for computing the address of MemCheck's finalization.
Hence, it MUST be just before the finalization and be empty. If you want to change that, you'll have
to change the way memcheck's finalization is seeked}
begin
end;
initialization
MemCheckLogFileName := ChangeFileExt(ParamStr(0), MemCheckLogFileNameSuffix);
finalization
if ExceptProc = @MyExceptProc then
{Exception logger installed}
Close(SevereExceptionsLogFile);
if MemCheckInitialized then
begin
if MemCheckActive then
begin
UnMemChk;
OutputAllCollectedInformation;
GoThroughAllocatedBlocks;
end;
if CheckHeapStatus then
HeapStatusSynchro.Destroy;
LinkedListSynchro.Destroy;
FreeMem(TimeStamps);
FreeMem(AllocatedInstances);
OutOfMemory.Destroy;
MemCheckLogFileName := MemCheckLogFileName + '.$$$';
if FileExists(MemCheckLogFileName) then
DeleteFile(MemCheckLogFileName);
end;
end.
}}}
リソースDLLウィザード
プロジェクトマネージャから、「新規プロジェクトを追加」-「リソースDLLウィザード」と操作し、各種設定を行うと、プロジェクト projectname.eng とか projectname.jpnとかが作成される。
拡張子は言語やロケールを示す。
このプロジェクトはリソースのみが入っているDLLになる。
フォーム付のライブラリを使用している場合は、プロジェクトにそのユニットを追加する必要がある。（DLL化した方が好ましいかも）
尚、この変更後、リソースDLLのフォームにコンポーネントを追加するのはGUIビルダからは不可能。通常のフォームとファイルを入れ換えて操作したり、直接.dfmファイルをテキストエディタで編集するなどの対応が必要
ロケールの判定方法
Windows APIの GetLocaleInfoを使用する。
{{{
int GetLocaleInfo(
LCID Locale, // locale identifier
LCTYPE LCType, // type of information
LPTSTR lpLCData, // address of buffer for information
int cchData // size of buffer
);
}}}
Locale ロケール種類を指定
LOCALE_SYSTEM_DEFAULT システムロケール
LOCALE_USER_DEFAULT ユーザーロケール
*なおリソースDLLウィザードを使うと、ユーザーロケールを使用している。
LCType 取得するデータの指定
LOCALE_SENGLANGUAGEと指定すると、英語での言語種類が取得できる。
他にもいろいろ
lpLCData データ取得バッファ 文字列で取得する。
cchData データ取得バッファのサイズ
事例３：ログ収集とかでタイマ精度を考える場合
Formには ログ収集周期のタイマを作成しておく
{{{
TMyThread = class(TThread)
....
end;
TMyForm = class(TThread)
....
procedure LogTimerTimer;
...
MyThread : TMyThread;
....
end;
procedure TMyForm.FormCreate
begin
...
// suspend 状態で立上げ
MyThread := TMyThread.Create( False );
...
end;
procedure TMyForm.LogTimerTimer;
begin
// OnTimerイベントで、スレッドがSUSPEND状態なら
// 動作を再開する。
if MyThread.Suspended then
MyThread.Resume;
end;
procedure TMyThread.SampleLog;
begin
// ログ収集処理
...
end;
procedure TMyThread.Execute;
begin
while not Terminated do
begin
SampleLog;
Suspend;
end;
end;
}}}
これをタイマイベントのプロシージャにする場合では、ファイル書込みなどにかかる時間によっては、同時に２つのメソッドが動く危険がありますので、その回避が出来ます。
また、ログ動作中に例外メッセージが発生するような場合、タイマーで動くと、前のメソッド終了しない内に次のメソッドが動作するようになり、大量にメッセージウィンドウを開きます。その結果、メモリを消費して最後には以上終了してしまいます。
この場合は、タイマでは停止スレッドを再開するだけなので、ログ動作自体による異常はありえません。また、スレッドの動作が停止してメッセージが表示されているだけなので、メッセージの確認ボタンを操作すれば次に進みます。
もっとも、例外メッセージが出ること自体の方が問題ですが...
事例１：一秒周期の表示更新
Formには表示更新のメソッドを作成しておく
{{{
TMyThread = class(TThread)
....
end;
procedure TMyThread.IndicateAll;
begin
MyForm.IndicateAll;
end;
procedure TMyThread.Execute;
begin
while not Terminated do
begin
Sleep( 1000 );
Application.ProcessMessages;
if not Form.Visible then continue;
Synchronize(IndicateAll);
end;
end;
}}}
これをタイマイベントのプロシージャにする場合では、描画にかかる時間によっては、同時に２つのメソッドが動く危険がありますので、その回避が出来ます。
尚、これだと、１秒周期でしか、スレッドを終了できないので、実際にはGetTicCountなどを用いてタイマ監視を行い、スレッドの終了は細かいタイミングでできるようにするべきです。
事例２：同時動作
たとえば、特定のボタンをクリックしたとき、１秒間、特定のワードを１にして、１秒後０に戻すという動きをしたい場合。
{{{
// ボタンのクリックで動作開始
procedure TMyForm.ButtonClick( Sender, object )
var
MyThread : TMyThread;
begin
MyThread := TMyThread.Create( false );
end;
TMyThread = class(TThread)
....
end;
procedure TMyThread.Execute;
const
dev = 'D';
address = 1000;
begin
// 1をセット
SharedMemPutCommand( dev, address, 1 );
// 1秒間WAIT
Sleep( 1000 );
Application.ProcessMessages;
// 0をセット
SharedMemPutCommand( dev, address, 0 );
// 終了
end;
}}}
この程度であれば、スレッドを使ってもそれほどの変化はありませんが、
この処理内容が増えれば増えるほど、スレッドを使用することで
分かりやすいソースを書くことが出来るようになります。
{{{
uses TypInfo;
TEnumeration = ( EnumA, EnumB, EnumC );
a : TEnumeration
s : string;
// 直接代入せずOrdを使う
s := GetEnumName( TypeInfo(TEnumeration), Ord(a) );
// これで文字が入ります。
GetEnumValueで逆方向の変換も可能
a := TEnumeration( GetEnumValue(
TypeInfo(TEnumeration), 'EnumA' ));
}}}
一覧の作り方
{{{
var
Fmt :TEnumerationt;
begin
cbFormat.Items.Clear;
for Fmt := low( TEnumeration) to high(TEnumeration) do
begin
cbFormat.Items.Add(
GetEnumName(
TypeInfo(TEnumeration),Ord(Fmt)));
end;
}}}
<<list filter "[tag[DelphiComponent]]">>
Delphiでは同じ名前のfunction, procedureを定義される場合があります。
これは、パラメータを変えて同じ機能を行うなどと言った場合に行われます。
通常 宣言の際にoverload 宣言されています。
{{{
type
MyClass = class
...
MyData : string;
...
procedure Add( val : integer ); overload;
procedure Add( str : string ); overload;
....
end;
....
procedure MyClass.Add ( val : integer );
var
s :string;
begin
s := IntToStr( val );
Add( s );
end;
procedure MyClass.Add( str : string );
begin
MyData := MyData + ',' + str;
end;
}}}
WindowsXPはOK
コマンドプロンプトを開いて
{{{
regsvr32 /u zipfldr.dll
regsvr32 /u cabview.dll
}}}
で無効化、早くなります。
{{{
regsvr32 zipfldr.dll
regsvr32 cabview.dll
}}}
で元に戻ります。
豚挽き肉、しょうがのみじん切り、にんにくのみじん切りを胡麻油で炒める。豆板醤と塩コショウで味付
しょうがの千切りをなべで乾煎りして、やさいと水をいれる。
中華スープとしょうゆで味付け
最初のやつを混ぜたら出来上がり。
複数の子Windowを作った際に各々の子Windowをタスクバーについかする方法
メインフォームのProtectedに下記のCreateParamsメソッドを再定義する。
{{{
type
TForm1 = class(TForm)
private
{ private 宣言 }
protected
procedure CreateParams(var Params: TCreateParams); override;
public
{ public 宣言 }
end;
}}}
それでメソッドは以下のように定義する。
{{{
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited;
if FormStyle in [fsNormal, fsStayOnTop] then begin
if BorderStyle in [bsSingle, bsSizeable] then begin
Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;
Params.WndParent := GetDesktopWindow(); ←タスクバーにメインフォーム登録
end;
end;
}}}
end;
◆小数点以下を切り捨て。戻り値は実数
int(1.5) =1
int(0.1) =0
int(0.0) =0
int(-0.1) =0
int(-1.5) =-1
◆小数点以下を切り捨て。戻り値は整数
Trunc(1.5) =1
Trunc(0.1) =0
Trunc(0.0) =0
Trunc(-0.1) =0
Trunc(-1.5) =-1
◆その実数を超えない最大の整数
Floor(1.5) =1
Floor(0.1) =0
Floor(0.0) =0
Floor(-0.1) =-1
Floor(-1.5) =-2
◆その実数より小さくない最小の整数
Ceil(1.5) =2
Ceil(0.1) =1
Ceil(0.0) =0
Ceil(-0.1) =0
Ceil(-1.5) =-1
四捨五入を考えると以下の表の様になります。
このことより、正の値だけならTrunc(x+0.5）が使用可能だが、
負の値も使用する場合はFloor(x+0.5)、Ceil(x-0.5)のどちらかが妥当
|x|Trunc(x+0.5)|Floor(x+0.5)|Ceil(x-0.5)|
|1.6|2|2|2|
|1.5|2|2|1|
|1.4|1|1|1|
|0.6|1|1|1|
|0.5|1|1|0|
|0.4|0|0|0|
|0.0|0|0|0|
|-0.4|0|0|0|
|-0.5|0|0|-1|
|-0.6|0|-1|-1|
|-1.4|0|-1|-1|
|-1.5|-1|-1|-2|
|-1.6|-1|-2|-2|
FormatFloatの形式指定で正／負／ZEROの形式を分けられる
{{{
var
s : string;
d : double;
begin
d := xxxx
....
s := FormatFloat( '＋0000.0;－0000.0;±0000.0 );
}}}
セミコロンで区切って、最初が＋の時、次が－のとき、最後がゼロのとき
ゼロのところを省略するとゼロの場合はプラスのところが適用される。
{{{
procedure proc1(
Arg1 : datataype;
Arg2 : datatype ....);
const
定数の宣言
var
変数の宣言
begin
動作の定義
end;
function func1(
Arg1 : datataype;
Arg2 : datatype ....)
: datatype
const
定数の宣言
var
変数の宣言
begin
動作の定義
result := ....
動作の定義
end;
}}}
手続き内の例外の書き方は以下のようになる。
{{{
procedure xxxx( ... ) ...
begin
try
try
try
except
end;
try
except
end;
finally
...
end;
except
end;
end;
}}}
排他処理が必要な箇所の前に、 WaitFor、終わった後でRelease すればOK
プロセス間で排他処理が必要な場合は、TNamedMutexを使用する。
プロセス内の場合は、TAnonymousMutexでも良い
{{{
{----------------------------------
Mutex処理ラッパークラス
排他制御に使用してください
2010.01.14
----------------------------------}
unit MutexUnit;
{$WARN Unsafe_Type off }
interface
uses
windows;
Type
TNamedMutex = class
protected
hMutex : THandle;
FMutexName : string;
public
constructor Create( AMutexName : string );
destructor Destroy; override;
procedure WaitFor; virtual;
procedure Release; virtual;
property Handle : THandle read hMutex;
property MutexName : string read FMutexName;
end;
TAnonymousMutex = class( TNamedMutex )
public
constructor Create; reintroduce;
procedure WaitFor; override;
property Handle;
end;
implementation
{ TNamedMutex }
constructor TNamedMutex.Create(AMutexName: string);
begin
inherited Create;
hMutex := 0;
FMutexName := AMutexName;
end;
destructor TNamedMutex.Destroy;
begin
if hMutex <> 0 then
begin
Release;
end;
inherited;
end;
procedure TNamedMutex.Release;
begin
CloseHandle( hMutex );
hMutex := 0;
end;
procedure TNamedMutex.WaitFor;
begin
if hMutex <> 0 then
exit;
hMutex := CreateMutex(nil,False, PChar(MutexName));
WaitForSingleObject(hMutex, INFINITE);
end;
}}}
文字 cを列挙型で定義するときは下のように定義
{{{
type TChrEnum = ( ce0 = ord('0'), ce1 = ord('1') ... );
}}}
列挙型から文字を取り出すときは、以下のように記述
{{{
var
c1,c2 : char
...
begin
...
c1 := chr( integer(ce0) );
c2 := char( ce1 );
end;
}}}
文字コードを取得する場合はOrdを使用する。
{{{
i := Ord('A');
}}}
文字コードから文字を取得する場合はChr
{{{
c := chr($30+n);
}}}
文字列内の[']
そもそもPascalの文法として、文字列のなかにアポストロフィ(')を含める
ときには、それを続けて書くというきまりになっています。Delphi言語でも
Helpに載っております。
{{{
str := 'aaaaaa + bbbbbb +'' ''+ccc+'' ''';
}}}
1.TFormのメソッド BringToFrontを使用する
2.Win32のSetWindowPosを使用する
{{{
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE)
}}}
ちなみに後ろにもってくには
1.TFormのメソッド SendToBackを使用する
2.Win32のSetWindowPosを使用する
{{{
SetWindowPos(Handle, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE)
}}}
最前面に表示する方法
1.TFormのメソッド BringToFrontを使用する
2.Win32のSetWindowPosを使用する
SetWindowPos(Handle, HWND_TOPMOST , 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE)
ちなみに後ろにもってくには
1.TFormのメソッド SendToBackを使用する
2.Win32のSetWindowPosを使用する
SetWindowPos(Handle, HWND_BOTTOM , 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE)
構造体 record型
Cでいう構造体にあたるもの
{{{
PName = ^TName;
TName = record
Size: Integer;
Time: Integer;
Msg: array[0..0] of Char;
end;
}}}
って感じで定義
record型名は先頭をTにする。
そのポインタの型名も準備しこれは先頭をPにする。
定数にする場合は
{{{
Name : array[0..1] of TName = (
( Size:10; Time:1; Msg:'aa' ),
....
);
}}}
ってかんじで定義
<<list filter "[tag[DelphiLibrary]]">>
浮動小数点型 の指数部の求め方
浮動小数点型 x.xxxxxEnnnの指数部nnnを求める方法は、
Log10関数で１０の対数を求めて、Floor（－方向の小さい値にする切捨て）を指数にして計算する。
指数部
Exponent := Floor( log10( abs( Extended_data) ) );
仮数部
Mantissa := Extended_data / power( 10, Exponent );
Position プロパティが poDesktopCenterの場合に画面からはみ出した。
マルチモニタのため→シングルモニタで使用したらOK
また、PositionプロパティをpoScreenCenterにしたところOKでした。
poScreenCenterにするとモニタを選んで中心にあわせる動きみたい。
秀丸
editor.bat をPATHの切られているところに作成
{{{
---editor.bat の内容 ----------
start C:\Progra~1\Hidemaru\Hidemaru.exe /j%1,%2 %3
----------------------------
}}}
Delphiの「ツール」－「ツールの設定」で「ツールオプション」ダイアログ表示
「追加」を押す
タイトル←「秀丸で編集」 とか
プログラム←「cmd.exe」
作業フォルダ← 「C:\Program Files\Hidemaru」
実行時引数←「 /c editor.bat $ROW $COL $EDNAME 」
以上を設定し 「OK」をクリック
複数のコントロールでのイベントハンドラの共有
複数のコントロールでイベントハンドラを共有する場合は、
どのコントロールで発生したかの判定には、引数で与えられるSenderを使用しましょう。
SenderはTObjectの継承クラスになっていますので、各コントロールクラスの型チェックや、
型キャストで そのコントロールの情報を得られます。
わざわざ、コントロールの名前を探したりするのは無駄です。
<<list filter "[tag[言語仕様]]">>
複数の変数を同じ配列数にしたい場合がある。
たとえば、比較データを定義する場合に
{{{
const
IndexList : array[1..10] of integer =(...);
DataList : array[1..10] of sting=(...);
}}}
という場合。
これは、
{{{
type
TSoejiList = 1..10;
const
IndexList : array[TSoejiList ] of integer =(...);
DataList : array[TSoejiList ] of sting=(...);
}}}
と記述するとOK
関数、手続きのポインタ
手続きのポインタは ユニットSysUtils で
{{{
type
TProcedure = procedure;
}}}
と定義されている。
関数は
{{{
type
TFuncA = function ( index : integer ) : integer;
}}}
って形で引数のパターンを変えて定義する。
定義されてないところは、nilをセットすればよいが。
チェックするときは if func = nil ではチェックできないので
手続きや関数を呼ぼうとしてしまうため。
Assigned を使用する。